106027_MehrfachmarkierungDic
06.06.2016 17:31:04
Michael
Hi Thomas,
das geht am einfachsten mit einem "Dictionary".
Näheres dazu kannst Du recherchieren mit: Excel vba Scripting.dictionary
Der Code:
Option Explicit
Sub mehrfacheMarkieren()
Dim it, oDic As Object, beg$, aBeg, key$, i&
Dim r As Range, vorh As Boolean
Set oDic = CreateObject("scripting.dictionary")
'Range("A1,c3").Select Diese Zeile bitte in der Datei löschen****
For Each r In UsedRange
beg = r.Text
If beg "" Then
aBeg = Split(Trim(LTrim(beg)), ",")
If UBound(aBeg) >= 0 Then
For i = 0 To UBound(aBeg)
key = Trim(LTrim(aBeg(i)))
If key "" Then
If oDic.exists(key) Then
oDic(key) = oDic(key) & "," & r.Address(0, 0)
Else
oDic(key) = r.Address(0, 0)
End If
End If
Next
Else
MsgBox "warum: " & beg
End If
End If
Next
' So kannst Du das Dic ausgeben lassen *****
'Range("F1").Resize(oDic.Count) = WorksheetFunction.Transpose(oDic.keys)
'Range("G1").Resize(oDic.Count) = WorksheetFunction.Transpose(oDic.items)
For Each it In oDic.items
If Len(it) > 2 Then
If vorh Then
beg = beg & "," & it
Else
beg = it
vorh = True
End If
End If
Next
Range(beg).Select
End Sub
Die Datei: https://www.herber.de/bbs/user/106032.xlsm
Schöne Grüße,
Michael