Ergänzung eines Makros
22.11.2004 02:58:37
Arpad
vor einiger Zeit hat mir hier im Forum jemand ausgezeichnet geholfen bei einer Makrogeschichte. Es ging darum, jeweils drei Datenblöcke aus je 3 Listen in einer Ausgabeliste nebeneinanderzustellen und so direkt vergleichbar zu machen.
Nun hat sich mein Problem erweitert: Es gibt 5 Listen (+eine Ausgabeliste) und sechs Datenblöcke.
Ich habe versucht, das Makro anzupassen, aber ich verstehe nur die einfachen Befehle und Schleifen. Könnt Ihr mir helfen?
Viele Grüße
Arpad
Die Datenlage:
https://www.herber.de/bbs/user/13747.xls
5 Listen mit geweils 8 Spalten mit den gleichen Überschriften.
In den Listen sind die Daten der Spalte A (Eintrag) und Spalte B (ID) teilweise identisch, teilweise unterschiedlich (es gibt aber Überschneidungen).
Das Problem:
Suche in allen Listen (L1, L2, L3, La, Lb) die übereinstimmenden IDs (Spalte B). Gib für diese IDs die Daten aller Listen in der Ausgabeliste L4 aus, und zwar so, daß jeweils entsprechende Daten nebeneinander stehen (also bspw. von allen fünf Listen die Werte von Spalte X: QM nebeneinander usw.).
Falls in einer Liste (z. B. Lb) die ID nicht vorhanden ist, gib die Meldung Nur in Liste L1, L2, L3, La vorhanden aus. Falls in zwei, drei, vier Listen die ID nicht vorhanden ist, gib entsprechende Meldungen aus.
Suche in den ersten 210 Zeilen jeder Liste.
Was sich geändert hat:
- in L1, L2, L3 sind die orange markierten Daten hinzugekommen
- es sind die Listen La und Lb hinzugekommen
- in L4 sollen bei X: QM, Y: Höhe und Z: Kosten auch noch die Listen La und Lb berücksichtigt werden. Außerdem sollen noch drei Spaltenblöcke R: Mitbewohner, S: Tiere und T: Stockwerk aufgenommen werden.
Bei der Spalte Meldung sollen auch die neuen zwei Listen berücksichtigt werden.
Der bisherige Code:
Dim L1, L2, L3, L4, X As Worksheet
Dim xFind, xFind2 As Range
Dim i, k, m, n As Integer
Dim arr As Variant
Sub Zusammenfassen()
Application.ScreenUpdating = False
Set L1 = Sheets("L1")
Set L2 = Sheets("L2")
Set L3 = Sheets("L3")
Set L4 = Sheets("L4")
Löschen
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "X"
Set X = Sheets("X")
L1.Range("A1:E1001").Copy X.Range("A1")
L2.Range("A1:E1001").Copy X.Range("F1")
L3.Range("A1:E1001").Copy X.Range("K1")
Application.CutCopyMode = False
Range("A1:E1001").Sort Key1:=Range("C2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("F1:J1001").Sort Key1:=Range("H2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("K1:O1001").Sort Key1:=Range("M2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
For i = 3 To 1002
Set xFind = X.Range("C2,H2,M2").Find(WorksheetFunction.Max(X.Range("C2,H2,M2")))
If Not xFind Is Nothing Then
Range(xFind, xFind.Offset(0, 2)).Font.Bold = True
Range(xFind.Offset(0, -2), xFind.Offset(0, -1)).Copy L4.Range("B" & i)
L4.Range("A" & i) = i - 2
wert = xFind.Offset(0, -1).Value
m = 1
p = 0
For k = 2 To 12 Step 5
p = p + 1
Set xFind2 = X.Columns(k).Find(wert)
If Not xFind2 Is Nothing Then
If arr = 0 Then
arr = "L" & p
Else
arr = arr + " und L" & p
End If
z = z + 1
For n = 1 To 3
m = m + 3
xFind2.Offset(0, n).Copy L4.Cells(i, m)
Next n
m = m - 8
Range(xFind2.Offset(0, -1), xFind2.Offset(0, 3)).Delete Shift:=xlUp
End If
Next
Else
Exit For
End If
If z <> 3 Then
L4.Range("M" & i).Value = "Nur in " & arr & " vorhanden"
End If
z = 0
arr = 0
Next
Application.DisplayAlerts = False
X.Delete
L4.Activate
Schön_machen
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub Schön_machen()
bRow = [B65536].End(xlUp).Row
Range("A3:M" & bRow).Select
Selection.Borders.LineStyle = xlContinuous
With Selection.Font
.Name = "Times New Roman"
.Size = 12
End With
Range("D3:F" & bRow).Interior.ColorIndex = 37
Range("G3:I" & bRow).Interior.ColorIndex = 34
Range("J3:L" & bRow).Interior.ColorIndex = 36
Range("A:A,C:C").HorizontalAlignment = xlCenter
Range("A2").Select
End Sub
Sub Löschen()
L4.Activate
bRow = [B65536].End(xlUp).Row
If bRow > 2 Then Rows("3:" & bRow).Delete Shift:=xlUp
End Sub