Daten aus Spalte auslesen und dazugehörige Namen a

Hallo,
ich bin neu hier und habe eine Frage zu einem Problem bezüglich VBA. Mein Wissensstand zu VBA hält sich auch in Grenzen...
Mein Problem ist:
Ich habe zwei Spalten, in der einen Stehen normale Namen, und in der anderen verschiedene Typen, welche durch Bindestriche getrennt sind. Formal sieht es so aus:
Spalte 1 Spalte 2
Name 1 WSSDR-FSRS-Q2U
Name 2 WSSDR-KL1L-Ro1_2
Name 3 Ro1_2-WSSDM-WSSDR-FSRS-FSLS
Das Makro, welches ich programmieren muss, muss den verschiedenen Typen aus Spalte 2 die Namen aus Spalte 1 zuweisen....also:
WSSDR enthält: Name 1, Name 2, Name 3
FSRS enthält: Name 1, Name 3
Q2U enthält: Name 1
Kl1L enthält: Name 2
Ro1_2 enthält: Name 2, Name 3
usw......
Wie sieht der Programmtext bzw. das fertige VBA-Programm hierfür aus?
Ich bitte um Hilfe!
Vielen Dank im Voraus!
Mit freundlichen Grüßen
Christoph S.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Namen() Dim objTyp As Object, vArr, vTmp, i As Long, j As Integer Set objTyp = CreateObject("scripting.dictionary") vArr = Range(Cells(1, 1), Cells(Rows.Count, 2).End(xlUp)) For i = 1 To UBound(vArr) vTmp = Split(vArr(i, 2), "-") For j = 0 To UBound(vTmp) If objTyp.exists(vTmp(j)) Then objTyp(vTmp(j)) = objTyp(vTmp(j)) & ", " & vArr(i, 1) Else objTyp(vTmp(j)) = vArr(i, 1) End If Next Next With Worksheets.Add .Cells(1, 1).Resize(objTyp.Count) = WorksheetFunction.Transpose(objTyp.keys) .Cells(1, 2).Resize(objTyp.Count) = WorksheetFunction.Transpose(objTyp.items) End With End Sub

Hallo Peter,
mein Programmtext lautet nun also:

Sub Namen()
Dim objTyp As Object, vArr, vTmp, i As Long, j As Integer
Set objTyp = CreateObject("scripting.dictionary")
vArr = Range(Cells(1, 1), Cells(Rows.Count, 2).End(xlUp))
For i = 1 To UBound(vArr)
vTmp = Split(vArr(i, 2), "-")
For j = 0 To UBound(vTmp)
If objTyp.exists(vTmp(j)) Then
objTyp(vTmp(j)) = objTyp(vTmp(j)) & ", " & vArr(i, 1)
Else
objTyp(vTmp(j)) = vArr(i, 1)
End If
Next
Next
With ThisWorkbook.Worksheets("Tabelle1") ' den Tabellenblattnamen ggf. anpassen!
vArr = .Range(.Cells(1, 1), .Cells(Rows.Count, 2).End(xlUp))
End With
End Sub

Wenn ich das so eingebe, kommt keine Fehlermeldung mehr beim Ausführen, jedoch passiert auch nichts innerhalb der Tabellen.
Mit freundlichen Grüßen
Christoph Sauer

Sub Namen() Dim objTyp As Object, vArr, vTmp, i As Long, j As Integer Set objTyp = CreateObject("scripting.dictionary") With Worksheets("RohDaten") 'anpassen vArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(xlUp)) End With For i = 1 To UBound(vArr) vTmp = Split(vArr(i, 2), "-") For j = 0 To UBound(vTmp) If objTyp.exists(vTmp(j)) Then objTyp(vTmp(j)) = objTyp(vTmp(j)) & ", " & vArr(i, 1) Else objTyp(vTmp(j)) = vArr(i, 1) End If Next Next With Worksheets("Ausgabe") 'anpassen .Cells(1, 1).Resize(objTyp.Count) = WorksheetFunction.Transpose(objTyp.keys) .Cells(1, 2).Resize(objTyp.Count) = WorksheetFunction.Transpose(objTyp.items) End With End Sub

Sub Namen() Dim objTyp As Object, vArr, vTmp, i As Long, j As Integer Set objTyp = CreateObject("scripting.dictionary") With Worksheets("Tabelle1") vArr = .Range(.Cells(4, 1), .Cells(.Rows.Count, 2).End(xlUp)) End With For i = 1 To UBound(vArr) vTmp = Split(vArr(i, 2), "-") For j = 0 To UBound(vTmp) If objTyp.exists(vTmp(j)) Then objTyp(vTmp(j)) = objTyp(vTmp(j)) & ", " & vArr(i, 1) Else objTyp(vTmp(j)) = vArr(i, 1) End If Next Next With Worksheets("tabelle2") .Cells(1, 1).Resize(objTyp.Count) = WorksheetFunction.Transpose(objTyp.keys) .Cells(1, 2).Resize(objTyp.Count) = WorksheetFunction.Transpose(objTyp.items) End With End Sub

Beliebteste Forumthreads (12 Monate)

Daten aus Spalte auslesen und dazugehörige Namen a

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

337 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Daten aus Spalte auslesen und dazugehörige Namen a

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

337 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread