Letzte Hürden bei Makro
23.11.2004 08:28:57
Arpad
komme mit meinem Makro nicht mehr weiter...
Das Problem:
Die Daten aus 5 Listen (L1-L5) sollen in einer Ausgabeliste (Lausga) Kategorie für Kategorie nebeneinandergestellt werden. Es gibt in jeder Liste 207 Datensätze, die mit IDs gekennzeichnet sind.
Mein bisheriges Makro (anbei) liefert schon erste Ergebnisse, es sind aber noch zwei Bugs drin:
- in den hinteren drei Kategorien werden in der Ausgabeliste die falschen Werte ausgegeben
- die Zuordnung der ausgegebenen Werte zu den Listen ist nicht richtig (z. B. wird in der Spalte für L2 der Wert für L4 ausgegeben)
Habe leider nicht viel Ahnung von VBA ... das Problem müßte wohl irgendwo in der For-Schleife liegen oder ich bin mit den Offsets auf Kriegsfuß.
Eine Beispieldatei findet Ihr hier: https://www.herber.de/bbs/user/13794.xls
Wäre Euch sehr dankbar für Hilfe!
Viele Grüße
Árpád
Dim L1, L2, L3, L4, L5, Lausga, 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")
Set L5 = Sheets("L5")
Set Lausga = Sheets("Lausga")
Loeschen
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "X"
Set X = Sheets("X")
L1.Range("A1:H207").Copy X.Range("A1")
L2.Range("A1:H207").Copy X.Range("I1")
L3.Range("A1:H207").Copy X.Range("Q1")
L4.Range("A1:H207").Copy X.Range("Y1")
L5.Range("A1:H207").Copy X.Range("AG1")
Application.CutCopyMode = False
Range("A1:H207").Sort Key1:=Range("C2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("I1:P207").Sort Key1:=Range("K2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("Q1:X207").Sort Key1:=Range("S2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("Y1:AF207").Sort Key1:=Range("AA2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("AG1:AN207").Sort Key1:=Range("AI2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
For i = 3 To 209
Set xFind = X.Range("C2,K2,S2,AA2,AI2").Find(WorksheetFunction.Max(X.Range("C2,K2,S2,AA2,AI2")))
If Not xFind Is Nothing Then
Range(xFind, xFind.Offset(0, 4)).Font.Bold = True
Range(xFind.Offset(0, -2), xFind.Offset(0, -1)).Copy Lausga.Range("B" & i)
Lausga.Range("A" & i) = i - 2
wert = xFind.Offset(0, -1).Value
m = 3
p = 0
For k = 2 To 40 Step 8
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 6
m = m + 5
xFind2.Offset(0, n).Copy Lausga.Cells(i, m)
Next n
m = m - 31
Range(xFind2.Offset(0, -1), xFind2.Offset(0, 3)).Delete Shift:=xlUp
End If
Next
Else
Exit For
End If
If z <> 5 Then
Lausga.Range("AH" & i).Value = "Nur in " & arr & " vorhanden"
End If
z = 0
arr = 0
Next
Application.DisplayAlerts = False
X.Delete
Lausga.Activate
Schoen_machen
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub Schoen_machen()
bRow = [B65536].End(xlUp).Row
Range("A3:AH" & bRow).Select
Selection.Borders.LineStyle = xlContinuous
With Selection.Font
.Name = "Times New Roman"
.Size = 12
End With
Range("D3:H" & bRow).Interior.ColorIndex = 37
Range("I3:M" & bRow).Interior.ColorIndex = 34
Range("N3:R" & bRow).Interior.ColorIndex = 36
Range("S3:W" & bRow).Interior.ColorIndex = 33
Range("X3:AB" & bRow).Interior.ColorIndex = 35
Range("AC3:AG" & bRow).Interior.ColorIndex = 38
Range("A:A,C:C").HorizontalAlignment = xlCenter
Range("A2").Select
End Sub
Sub Loeschen()
Lausga.Activate
bRow = [B65536].End(xlUp).Row
If bRow > 2 Then Rows("3:" & bRow).Delete Shift:=xlUp
End Sub