Nochmal: Liste mit doppelten Merkmalen reduzieren
05.08.2003 18:28:55
cpete
Ich habe diese Frage schonmal um 16:30 gepostet, dabei hat mir Andreas Walter schon geholfen (das Makro läuft jetzt für 3000 zeilen in 12 sec. vorher waren es 120 sec). Trotzdem heisst das, dass das makro bei laengeren Tabellen bis vier Minuten läuft. Anyway: Hier ist das Problem:
Eine Liste mit vier Merkmalen (Spalten 2-5) soll so reduziert werden, dass nur noch Saetze übrigbleiben, die in den Merkmalen 1-3 eindeutig sind. Das vierte Merkmal soll in der letzten Spalte zusammengefasst werden.
Aus
Deutschland Berlin Tempelhof Käse
Deutschland Berlin Tempelhof Wurst
Soll
Deutschland Berlin Tempelhof Käse&Wurst
werden.
Hier ist mein VBA code. Ich weiss es ist "hard stuff"...
Hat jemand Ideen wie man das optimieren könnte?
Danke,
cpete
Sub reduce_list()
' Auto-Berechnung und Screen Update aus
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set R = Range("B1").CurrentRegion
' Am Ende muss ein zusätzlicher Satz eingefügt werden
I = R.Rows.Count + 1
For S = 1 To 10
Cells(I, S) = "ZZ"
Next S
Cells(I, 2) = 4
Cells(I, 7) = 0
' Da nur nach drei Dimensionen sortiert werden kann muessen
' Spalten 2 & 3 zusammengefasst werden
For I = 2 To R.Rows.Count
Cells(I, 1) = " & " ' Verknüpfungsoperator in Spalte 1
Cells(I, 9).FormulaR1C1 = "=RC[-7] & MID(RC[-6],1,5)"
Next I
' Sortieren der Tabelle
Cells.Select
Selection.Sort Key1:=Range("I2"), Order1:=xlAscending, Key2:=Range("D2") _
, Order2:=xlAscending, Key3:=Range("E2"), Order3:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
' Einfügen der Formeln
For I = 2 To R.Rows.Count
' Prüfung stimmt Eintrag mit darüberliegendem überein (Dim1-3)
Cells(I, 6).FormulaR1C1 = "=IF(AND(RC[-4]=R[-1]C[-4],RC[-3]=R[-1]C[-3],RC[-2]=R[-1]C[-2]),1,0)"
' Falls neue Kombi dann Dim 4 übernehmen
Cells(I, 7).FormulaR1C1 = "=IF(RC[-1]= 0, RC[-2], R[-1]C & RC[-6] & RC[-2])"
' Zusammengesetzte Kombi aus Dim 4
Cells(I, 8).FormulaR1C1 = "=IF(AND(RC[-2]=0,R[1]C[-2]=0),RC[-1],OFFSET(RC[-1],MATCH(0,R[1]C[-2]:R65536C6,0)-1,0))"
Next I
' Formeln jetzt berechnen
Application.Calculation = xlCalculationAutomatic
' Formeln durch Werte ersetzen
Columns("F:H").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
' Alle doppelten Sätze löschen
Dim Q As Long
Dim Letzte As Long
If [a65536] = "" Then
Letzte = [a65536].End(xlUp).Row
Else
Letzte = 65536
End If
On Error Resume Next
Rows(Letzte).Delete
For Q = Letzte To 2 Step -1
If Cells(Q, 6) <> 0 Then Rows(Q).Delete
Next
' Hilfsspalten löschen
For M = 1 To 4
Columns(6).Delete
Next
Application.ScreenUpdating = True
End Sub