Zellenwerte in Eingabemeldung, dynamisch -> Lupe

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

' ********************************************************************** ' 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

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

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

Beliebteste Forumthreads (12 Monate)

Zellenwerte in Eingabemeldung, dynamisch -> Lupe

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zellenwerte in Eingabemeldung, dynamisch -> Lupe

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

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread