Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1556to1560
1556to1560
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Zellenwerte in Eingabemeldung, dynamisch -> Lupe

Forumthread: Zellenwerte in Eingabemeldung, dynamisch -> Lupe

Zellenwerte in Eingabemeldung, dynamisch -> Lupe
13.05.2017 16:40:52
Peter
Hallo zusammen
Ich suche eine Möglichkeit, die Inhalte der Zellen, z.B. der Spalten AF4:AF; AU4:AU dynamisch in die Zellen-Eingabemeldungen zu kopieren (Datenüberprüfung). Auf diese Weise habe ich eine Art Lupenfunktion.
Hat jemand eine Idee, wie zu realisieren?
Danke.
Viele Grüsse,
Peter
Anzeige

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zellenwerte in Eingabemeldung, dynamisch -> Lupe
13.05.2017 17:09:05
Sepp
Hallo Peter,
in das Modul der Tabelle.
' **********************************************************************
' Modul: Tabelle1  Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, lngLast As Long
Dim vntList As Variant, vntValues As Variant
Dim strList As String

lngLast = Me.UsedRange.SpecialCells(xlCellTypeLastCell).Row

If Not Intersect(Target, Union(Range("AF4:AF" & lngLast), Range("AU4:AU" & lngLast))) Is Nothing Then
  vntValues = Range(Cells(4, Target.Column), Cells(lngLast, Target.Column))
  vntList = toArraySorted(vntValues)
  strList = Join(vntList, vbLf)
  For Each rng In Range(Cells(4, Target.Column), Cells(lngLast, Target.Column)).Cells
    With rng.Validation
      .Delete
      .Add Type:=xlValidateInputOnly
      .InputMessage = strList
    End With
  Next
End If
End Sub

Private Function toArraySorted(Field As Variant, Optional Uniqe As Boolean = True) As Variant
Dim objArrayList As Object
Dim lngR As Long, lngC As Long

On Error GoTo ErrExit

Set objArrayList = CreateObject("System.Collections.Arraylist")

With objArrayList
  For lngR = LBound(Field, 1) To UBound(Field, 1)
    For lngC = LBound(Field, 2) To UBound(Field, 2)
      If Not .Contains(Trim(Field(lngR, lngC))) Or Not Uniqe Then
        If Field(lngR, lngC) <> "" Then .Add Trim(Field(lngR, lngC))
      End If
    Next
  Next
  .Sort
  toArraySorted = .toArray
End With

Exit Function
ErrExit:
toArraySorted = -1
End Function

Gruß Sepp

Anzeige
AW: Zellenwerte in Eingabemeldung, dynamisch -> Lupe
13.05.2017 17:30:36
Peter
Hallo Sepp
Danke für Deine geschätzte Anwort.
Das ist genau das was ich suche, jedoch werden alle Zelleninhalte in die Eingabemeldung geschrieben. D.h. jede Zelle hat die gleiche Eingabemeldung, nämlich die Inhalte aller Zellen. Jedoch sollte in die jeweilige Eingabemeldung, nur der Wert der entsprechenden Zelle eingefügt und angezeigt werden. D.h. jede Zelle hat seine individuelle Eingabemeldung, der Inhalte der Zelle. Lässt sich das anpassen?
Danke.
Viele Grüsse
Peter
Anzeige
AW: Zellenwerte in Eingabemeldung, dynamisch -> Lupe
13.05.2017 17:39:04
Sepp
Hallo Peter,
dann so.
' **********************************************************************
' Modul: Tabelle1  Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, lngLast As Long

lngLast = Me.UsedRange.SpecialCells(xlCellTypeLastCell).Row

If Not Intersect(Target, Union(Range("AF4:AF" & lngLast), Range("AU4:AU" & lngLast))) Is Nothing Then
  For Each rng In Intersect(Target, Union(Range("AF4:AF" & lngLast), Range("AU4:AU" & lngLast))).Cells
    If Len(rng) Then
      With rng.Validation
        .Delete
        .Add Type:=xlValidateInputOnly
        .InputMessage = rng.Text
      End With
    Else
      rng.Validation.Delete
    End If
  Next
End If
End Sub

Gruß Sepp

Anzeige
AW: Zellenwerte in Eingabemeldung, dynamisch -> Lupe
13.05.2017 18:22:03
Peter
Hallo Sepp
Ja, genau so! Jedoch werden, im Gegensatz zur ersten Lösung, die Zeilenumbrüche der Zelle nicht übernommen. Das kommt ziemlich unübersichtlich rüber, d.h. wenn ein Text einer Zelle in vier Zeilen aufgeteilt ist, dass dann in der Eingabemeldung, der Zelleninhalt ebenfalls mit vier Zeilenumbrüche dargestellt wird. Wie müsste ich den Code anpassen, damit die Zeilenumbrüche übernommen werden?
Danke.
Viele Grüsse,
Peter
Anzeige
AW: Zellenwerte in Eingabemeldung, dynamisch -> Lupe
13.05.2017 18:40:11
Sepp
Hallo Peter,
die Größe der Eingabemeldung lässt sich nicht ändern, da wirst du auch mit den Umbrüchen Pech haben.
Gruß Sepp

Alternative mit einem Shape
13.05.2017 19:09:21
Sepp
Hallo Peter.
probier mal.
' **********************************************************************
' Modul: Tabelle1  Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim objShape As Object, lngLast As Long, strComment As String


If Not Intersect(Target, Union(Range("AF4:AF" & Rows.Count), Range("AU4:AU" & Rows.Count))) Is Nothing Then
  If Target.Count = 1 Then
    On Error GoTo NoShape
    HasShape:
    Set objShape = Me.Shapes("txtComment")
    
    With objShape
      .Visible = False
      .TextFrame.Characters.text = ""
      If Target.Count = 1 Then
        strComment = Target.text
        If strComment <> "" Then
          strComment = breakText(strComment, Cint(Target.ColumnWidth * 1.4))
          .TextFrame.Characters.text = strComment
          .Top = Target.Top + 5
          .Left = Target.Left + Target.Width + 5
          .Visible = True
        End If
      End If
    End With
  End If
Else
  On Error Resume Next
  Me.Shapes("txtComment").Visible = False
End If
Set objShape = Nothing

Exit Sub

NoShape:
If Err.Number = -2147024809 Then
  If makeComment Then
    Resume HasShape
  Else
    Exit Sub
  End If
End If
End Sub

Private Sub dummy()
Me.Shapes(Application.Caller).Visible = False
End Sub

Private Function makeComment() As Boolean
Dim objShape As Shape

On Error GoTo ErrExit

Set objShape = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 0#, 0#, 10#, 10#)

With objShape
  .Name = "txtComment"
  .Visible = msoFalse
  .OnAction = Me.Name & ".dummy"
  .Fill.ForeColor.RGB = RGB(255, 255, 225)
  .Line.ForeColor.RGB = RGB(100, 100, 100)
  .TextFrame.HorizontalAlignment = xlHAlignLeft
  .TextFrame.VerticalAlignment = xlVAlignTop
  .TextFrame.AutoSize = True
  .TextFrame2.WarpFormat = msoWarpFormat1
End With

makeComment = Err.Number = 0
Exit Function
ErrExit:
makeComment = False
End Function

Private Function breakText(ByVal text As String, ByVal länge As Integer) As String
Dim tmp As String, str As String
Dim lenT As Integer, i As Integer, n As Integer
lenT = Len(text)
n = 1
i = 1
Do
  tmp = Mid(text, i, länge)
  If lenT - i >= länge Then
    n = Len(tmp) - InStr(1, StrReverse(tmp), " ") + 1
  Else
    n = Len(tmp)
  End If
  str = str & Trim(Left(tmp, n)) & vbLf
  i = i + n
Loop While i < lenT
breakText = Left(str, Len(str) - 1)
End Function

Gruß Sepp

Anzeige
AW: Alternative mit einem Shape
13.05.2017 19:52:32
Peter
Hallo Sepp
Yeph, PERFEKT!
Ich habe den "* 1.4" Wert auf 5 erhöht und jetzt läuft es perfekt!!
Ein Problem habe jedoch noch, ich bekomme die alten, vorherigen Werte nicht raus. D.h. ich habe jetzt pro Zelle zwei Zelleninformations-PopUps. Man müsste zuvor eine Löschfunktion einbauen, so dass zuerst die alte Eingabeinformation gelöscht und erst dann die neue erstellt wird, wie könnte so eine Löschfunktion aussehen?

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If iVerfolgung Then ufVerfolgung.Aktualisieren  'wird für die Lupe benötigt
Dim objShape As Object, lngLast As Long, strComment As String
If Not Intersect(Target, Union(Range("AF4:AF" & Rows.Count), Range("AU4:AU" & Rows.Count))) Is  _
Nothing Then
If Target.Count = 1 Then
On Error GoTo NoShape
HasShape:
Set objShape = Me.Shapes("txtComment")
With objShape
.Visible = False
.TextFrame.Characters.text = ""
If Target.Count = 1 Then
strComment = Target.text
If strComment  "" Then
'strComment = breakText(strComment, CInt(Target.ColumnWidth * 1.4))
strComment = breakText(strComment, CInt(Target.ColumnWidth * 5))
.TextFrame.Characters.text = strComment
.Top = Target.Top + 5
.Left = Target.Left + Target.Width + 5
.Visible = True
End If
End If
End With
End If
Else
On Error Resume Next
Me.Shapes("txtComment").Visible = False
End If
Set objShape = Nothing
Exit Sub
NoShape:
If Err.Number = -2147024809 Then
If makeComment Then
Resume HasShape
Else
Exit Sub
End If
End If
End Sub

Danke
Viele Grüsse,
Peter
Anzeige
AW: Alternative mit einem Shape
13.05.2017 19:58:10
Sepp
Hallo Peter,
alle betroffenen Zellen auswählen > Datenüberprüfung > alle löschen
Gruß Sepp

AW: Alternative mit einem Shape
13.05.2017 20:17:08
Peter
Hallo Sepp
Ja genau so hab ich es gemacht :-)
Nochmals danke für Deine wertvolle und geschätzte Hilfe.
Viele Grüsse,
Peter
Anzeige
AW: Alternative mit einem Shape
13.05.2017 19:58:25
Peter
Hallo Sepp
Ich konnte die erste Variante löschen.
Wirklich eine sehr schöne und elegante "Lupen-Lösung", echt super, DANKE Dir!
Viele Grüsse
Peter
;
Anzeige
Anzeige

Infobox / Tutorial

Dynamische Eingabemeldungen in Excel mit der Lupenfunktion

Schritt-für-Schritt-Anleitung

Um Zellenwerte dynamisch in die Eingabemeldungen von Excel zu integrieren und so eine Lupenfunktion zu erstellen, kannst du folgenden VBA-Code verwenden. Dieser Code wird in das Modul der Tabelle eingefügt.

  1. Öffne Excel und drücke ALT + F11, um den VBA-Editor zu öffnen.
  2. Klicke im Projektfenster auf die entsprechende Tabelle (z.B. Tabelle1).
  3. Füge den folgenden Code in das Modul ein:
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range, lngLast As Long
    lngLast = Me.UsedRange.SpecialCells(xlCellTypeLastCell).Row

    If Not Intersect(Target, Union(Range("AF4:AF" & lngLast), Range("AU4:AU" & lngLast))) Is Nothing Then
        For Each rng In Intersect(Target, Union(Range("AF4:AF" & lngLast), Range("AU4:AU" & lngLast))).Cells
            If Len(rng) Then
                With rng.Validation
                    .Delete
                    .Add Type:=xlValidateInputOnly
                    .InputMessage = rng.Text
                End With
            Else
                rng.Validation.Delete
            End If
        Next
    End If
End Sub

Häufige Fehler und Lösungen

Fehler: Alle Zellen zeigen den gleichen Wert in der Eingabemeldung an.
Lösung: Stelle sicher, dass der Code die Eingabemeldung für jede Zelle individuell anpasst. Der oben angegebene Code sollte dies tun.

Fehler: Die Zeilenumbrüche werden in der Eingabemeldung nicht angezeigt.
Lösung: Die Größe der Eingabemeldung kann nicht geändert werden. Die Zeilenumbrüche werden standardmäßig nicht unterstützt. Du kannst jedoch eine alternative Methode verwenden, um die Inhalte anzuzeigen.

Alternative Methoden

Eine interessante Alternative zur dynamischen Eingabemeldung ist die Verwendung eines Shapes, um die Inhalte anzuzeigen. Hier ist ein Beispielcode, den du verwenden kannst:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim objShape As Object, strComment As String
    If Not Intersect(Target, Union(Range("AF4:AF"), Range("AU4:AU"))) Is Nothing Then
        If Target.Count = 1 Then
            On Error Resume Next
            Set objShape = Me.Shapes("txtComment")
            With objShape
                .Visible = False
                .TextFrame.Characters.text = ""
                strComment = Target.Text
                If strComment <> "" Then
                    .TextFrame.Characters.text = strComment
                    .Top = Target.Top + 5
                    .Left = Target.Left + Target.Width + 5
                    .Visible = True
                End If
            End With
        End If
    Else
        On Error Resume Next
        Me.Shapes("txtComment").Visible = False
    End If
End Sub

Praktische Beispiele

  1. Eingabemeldungen für Spalten anpassen: Du kannst den Code anpassen, um unterschiedliche Eingabemeldungen für jede Zelle in den Spalten AF und AU anzuzeigen.

  2. Shape verwenden: Erstelle ein Shape (Textbox) und nutze den zweiten Beispielcode, um die Inhalte bei Auswahl anzuzeigen. Dies ist besonders nützlich, wenn du mehr Informationen oder Formatierungen benötigst.

Tipps für Profis

  • Verwende die xlValidateInputOnly-Eigenschaft, um sicherzustellen, dass nur die Eingabemeldung und keine Liste angezeigt wird.
  • Teste deinen Code in einer Excel-Testdatei, um unerwünschte Änderungen an wichtigen Daten zu vermeiden.
  • Nutze Kommentare im VBA-Code, um deine Änderungen und Anpassungen zu dokumentieren.

FAQ: Häufige Fragen

1. Wie kann ich die Eingabemeldungen für mehrere Zellen gleichzeitig anpassen?
Du kannst den Code so anpassen, dass er alle gewünschten Zellen in einem Schritt verarbeitet, indem du die Union-Funktion nutzt.

2. Kann ich die Eingabemeldung auch für andere Zellen außerhalb der Spalten AF und AU verwenden?
Ja, du kannst die Bereiche in der Intersect-Funktion entsprechend anpassen, um deine gewünschten Zellen einzuschließen.

3. Was kann ich tun, wenn die Eingabemeldung nicht erscheint?
Überprüfe, ob die Zellen, für die du die Eingabemeldung festlegen möchtest, korrekt definiert sind und dass die Worksheet_Change-Ereignisprozedur korrekt funktioniert.

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige