AW: IDs in Zelle kopieren m Bedingungen
03.09.2021 12:46:24
migre
So, schau mal, hier nochmal der Code etwas ergänzt und auch auf die Anforderung für Spalte J erweitert - sollte das sein, was Du benötigst.
Sub a()
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim WsQ As Worksheet: Set WsQ = Wb.Worksheets("Datenbasis")
Dim WsZ As Worksheet: Set WsZ = Wb.Worksheets("Uebersicht")
Dim rIDList As Range, cID As Range
Dim rQcol As Range, rQrow As Range, rZ As Range, tRow&, tCol&
Dim rAllColID As Range, cAllColID As Range, aL As Object, aLItem, i&
Dim Clc, ScrUpd
With Application
Clc = .Calculation: .Calculation = xlCalculationManual
ScrUpd = .ScreenUpdating: .ScreenUpdating = False
End With
Set rZ = WsZ.Range("B2:I4")
With WsQ
Set rIDList = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
For Each cID In rIDList
Set rQrow = .Range(.Cells(cID.Row, 6), .Cells(cID.Row, 8))
Set rQcol = .Range(.Cells(cID.Row, 9), .Cells(cID.Row, 16))
tRow = Application.Match(1, rQrow, 0)
tCol = Application.Match(1, rQcol, 0)
rZ.Cells(tRow, tCol).Value = rZ.Cells(tRow, tCol).Value & cID.Value & ";"
rZ.Offset(tRow - 1, rZ.Columns.Count).Resize(1, 1) = rZ.Offset(tRow - 1, rZ.Columns.Count).Resize(1, 1) & cID.Value & ";"
Next cID
End With
Set rAllColID = rZ.Offset(, rZ.Columns.Count)
Set aL = CreateObject("System.Collections.ArrayList")
For Each cAllColID In rAllColID
For i = 1 To Len(cAllColID)
If Mid(cAllColID.Text, i, 1) ";" Then aL.Add Mid(cAllColID.Text, i, 1)
Next i
aL.Sort
cAllColID = vbNullString
For Each aLItem In aL
cAllColID = cAllColID & aLItem & ";"
Next aLItem
aL.Clear
Next cAllColID
With Application
.Calculation = Clc: .ScreenUpdating = ScrUpd
End With
Set Wb = Nothing: Set WsQ = Nothing: Set WsZ = Nothing
Set rIDList = Nothing: Set cID = Nothing: Set rQcol = Nothing
Set rQrow = Nothing: Set rZ = Nothing: Set rAllColID = Nothing
Set cAllColID = Nothing: Set aL = Nothing
End Sub
Zum Code:
Das vollständig auszukommentieren ist etwas langwierig ("VBA bescheiden"); ich versuche Dir die Logik zu erklären, nach der ich den Code geschrieben habe bzw. nach der er arbeitet.
Ziel ist eine Kreuztabelle, d.h. jeweils der (Überschneidungs-) Punkt aus Kategorie und Subkategorie. In der Ziel-Kreuztabelle sind die Kategorien gekippt, die Kategorien sind demnach die Zeilen, die Subkategorien die Spalten. D.h. je ID wird der Punkt in der Ziel-Kreuztabelle von der jeweiligen Position der "1" bestimmt.
D.h. der Code geht alle IDs in der Liste durch, und definiert je ID (je Zeile) 2 Bereiche - der erste Bereich sind die 3 Zellen der Kategorien (Fx:Hx), der 2 Bereich jene 8 Zellen der Subkategorie (Ix:Px). Dann wird je Bereich geprüft wo die "1" steht - der Rückgabewert gibt dann die Zeilen- und Spaltenziele für die Kreuztabelle wieder. Bsp. ID2 - Kategorien-Bereich (=Zeilen-Bereich) reicht von F3:H3, die "1" steht in G3, d.h. der Rückgabewert ist "2" (die 2. Position in diesem Zellbereich); damit wissen wir, dass ID2 in der Zieltabelle auf jeden Fall in die 2. Zeile gesetzt werden muss (Kategorie 2). Analog läuft der Subkategorien-Bereich (=Spalten-Bereich) von I3:P3, die "1" steht in L3, d.h. der Rückgabewert ist "4" (die 4. Position in diesem Zellbereich); damit wissen wir, dass ID2 in der Zieltabelle auf jeden Fall in die 4. Spalte gesetzt werden muss (Subkategorie 4). Damit ergibt sich, dass im Zielbereich (B2:I4) ID2 in die Zelle E3 (2. Zeile, 4. Spalte) gesetzt werden muss.
Gleichzeitig wird in Spalte J die jeweilige ID nochmals eingetragen. Nach Durchlauf aller IDs durchläuft der Code dann nochmal alle Zellen in Spalte J der Zieltabelle und sortiert die dortigen Einträge aufsteigend.
Kommst Du damit hin?
LG Michael