Erweiterung bestehendes Makro - Neue Spalte
04.02.2014 12:26:06
Daniel
ich habe ein kleines Makro, dass mir zwei Tabellen zu einer neuen zusammenfügt und für das ich eine kleine Erweiterung benötige (siehe Beispieldatei: https://www.herber.de/bbs/user/89091.xlsx )
Bis Zeile 14 in der Beispieldatei seht ihr, für welche Struktur das unten angefügte Makro funktioniert.
Ab Zeile 17 seht ihr, wie das erweiterte Makro aussehen sollte:
Es ist eine neue Spalte hinzugekommen (siehe Markierung Zelle B19) und diese neue Spalte müsste in dem Ergebnis hinten ebenfalls eingefügt werden (siehe Markierung Zelle N19).
Generelles Ziel (zur Info):
Zu jeder ID steht in Spalten rechts daneben mit einem X, in welcher Thematik sich die ID befindet (Beispieldatei ab Spalte M).
Dazu müsste aus einer Liste jede Thematik ein eigene Spalte bekommen, mit dem Namen der Thematik beschriftet werden und bei der ID ein X gesetzt werden.
Merci, Daniel
Aktuelles Makro (Beispieldatei bis Zeile 14):
Sub Liste()
Dim objThema As Object, objThemaID As Object
Dim rngC As Range
Dim arr, arrKeys
Dim i As Long, j As Long
Set objThema = CreateObject("Scripting.Dictionary")
Set objThemaID = CreateObject("Scripting.Dictionary")
For Each rngC In Range(Cells(4, 8), Cells(Rows.Count, 8).End(xlUp))
objThema(rngC.Value) = 0
objThemaID(rngC.Value & "_" & rngC.Offset(, 1).Value) = 0
Next
arr = Cells(3, 1).CurrentRegion
arrKeys = objThema.keys
ReDim Preserve arr(1 To UBound(arr), 1 To objThema.Count + 4)
For i = 0 To UBound(arrKeys)
arr(1, i + 5) = arrKeys(i)
Next
For i = 2 To UBound(arr)
For j = 5 To UBound(arr, 2)
If objThemaID.exists(arr(1, j) & "_" & arr(i, 1)) Then
arr(i, j) = "x"
End If
Next
Next
Cells(3, 13).Resize(UBound(arr), UBound(arr, 2)) = arr
End Sub