Suchergebnis zusammengefasst dargestellt

Hallo zusammen
Ich suche eine VBA-Lösung die mir die Suchergebnisse, entsprechend dem Suchkriterium jeweils in einer Zelle zusammengefasst anzeigt.
In der Tabelle 1, Spalte A2:A stehen Auftragsnummern, die nur 1x oder mehrfach vorkommen können.
In der Spalte B2:B stehen Nummern die jeweils einer oder mehrere Auftragsnummern zugewiesen sind.
Eine Auftragsnummer kann mehrere Nummern zugewiesen haben.
In der Tabelle 2 sollen entsprechend der Auftragsnummer (A2:A) + Index (B2:B) jeweils alle Nummernzuweisungen der Tabelle 1 zusammen gefasst dargestellt werden.
Wenn eine Auftragsnummer der Tabelle 2 in der Tabelle 1 nicht gefunden wird, dann soll anstelle der Nummerzuweisungen "na" stehen.
Könnt Ihr mir damit helfen, hat jemand eine Idee wie man das in VBA umsetzen könnte?
Testdatei: https://www.herber.de/bbs/user/134792.xlsm
Danke für Eure Hilfe.
Viele Grüsse,
Peter

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub TestIt() Dim objDic As Object Dim i As Long, lngNum As Long, lngLR As Long Set objDic = CreateObject("Scripting.Dictionary") With ThisWorkbook.Sheets("Tabelle1") For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row lngNum = .Cells(i, 1) If objDic.Exists(lngNum) Then objDic(lngNum) = objDic(lngNum) & ", " & .Cells(i, 2) Else objDic(lngNum) = .Cells(i, 2) End If Next End With With ThisWorkbook.Sheets("Tabelle2") lngLR = .Cells(.Rows.Count, 1).End(xlUp).Row .Cells(2, 3).Resize(lngLR - 1).ClearContents For i = 2 To lngLR lngNum = .Cells(i, 1) If objDic.Exists(lngNum) Then .Cells(i, 3) = objDic(lngNum) Else .Cells(i, 3) = "na" End If Next End With Set objDic = Nothing End Sub

Hallo,
dann z.B. so:

Option Explicit
Sub TestIt2()
Dim objDic As Object
Dim i As Long, j As Long, lngLR As Long
Dim lngNum As Long, lngType As Long
Dim vntNum, blnFnd As Boolean
Set objDic = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Sheets("Tabelle1")
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
blnFnd = False
lngNum = .Cells(i, 1)
lngType = .Cells(i, 2)
If objDic.Exists(lngNum) Then
vntNum = Split(objDic(lngNum), ", ")
For j = 0 To UBound(vntNum)
If vntNum(j) = lngType Then
blnFnd = True
Exit For
End If
Next
If Not blnFnd Then
objDic(lngNum) = objDic(lngNum) & ", " & lngType
End If
Else
objDic(lngNum) = lngType
End If
Next
End With
With ThisWorkbook.Sheets("Tabelle2")
lngLR = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(2, 3).Resize(lngLR - 1).ClearContents
For i = 2 To lngLR
lngNum = .Cells(i, 1)
If objDic.Exists(lngNum) Then
.Cells(i, 3) = objDic(lngNum)
Else
.Cells(i, 3) = "na"
End If
Next
End With
Set objDic = Nothing
End Sub

Grüße
Christian

Beliebteste Forumthreads (12 Monate)

Suchergebnis zusammengefasst dargestellt

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread