Ähnliche Begriffe finden

Forumthread: Ähnliche Begriffe finden

06.06.2016 15:38:18

hammsi

Hello again!
Ist es möglich, Zellen innerhalb eines Arbeitsblattes automatisch zu markieren, sobald darin enthaltene Begriffe in anderen Zellen ebenfalls vorkommen? Ich darf euch ein Musterdokument beisteuern, um die Geschichte etwas plastischer zu gestalten.
https://www.herber.de/bbs/user/106027.xlsx
Worttrennende Beistriche habe ich bewusst mal mit und mal ohne Leerzeichen versehen. Nach Adamriese sollten am Ende 5 Zellen markiert sein. Wenn es überdies dann noch ne Formel gibt, die diese Begriffe sogar extrahiert, wäre es der Super-Ober-Megahit.
Jetzt schon 1000 Dank und lg,
Thomas

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

106027_MehrfachmarkierungDic

06.06.2016 17:31:04

Michael
AW: 106027_MehrfachmarkierungDic

07.06.2016 10:32:02

hammsi
gerne, danke für die Rückmeldung owT

07.06.2016 16:15:41

Michael

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

AW: 106027_MehrfachmarkierungDic

07.06.2016 10:32:02

hammsi

Magic, funktioniert! Hat mir sehr geholfen - DANKE

gerne, danke für die Rückmeldung owT

07.06.2016 16:15:41

Michael

Beliebteste Forumthreads (12 Monate)

Forumthread: Ähnliche Begriffe finden

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread