Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
288to292
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
288to292
288to292
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Nochmal: Liste mit doppelten Merkmalen reduzieren

Nochmal: Liste mit doppelten Merkmalen reduzieren
05.08.2003 18:28:55
cpete
Hallo nochmal!
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

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Nochmal: Liste mit doppelten Merkmalen reduzieren
06.08.2003 10:16:14
Ingo
Hallo cpete???,
versuchs mal mit folgendem Code:

Sub reduce_list()
Dim zeile%
' Auto-Berechnung und Screen Update aus
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
' Sortieren der Tabelle
ThisWorkbook.Sheets("Tabelle1").Range("b1").CurrentRegion.Select
Selection.Sort Key1:=Range("b1"), Order1:=xlAscending, Key2:=Range("C1") _
, Order2:=xlAscending, Key3:=Range("D1"), Order3:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
' Einfügen der Formeln
zeile = 2
While ThisWorkbook.Sheets("Tabelle1").Cells(zeile, 2) <> ""
While ThisWorkbook.Sheets("Tabelle1").Cells(zeile, 2) = ThisWorkbook.Sheets("Tabelle1").Cells(zeile, 2).Offset(1, 0) And _
ThisWorkbook.Sheets("Tabelle1").Cells(zeile, 3) = ThisWorkbook.Sheets("Tabelle1").Cells(zeile, 3).Offset(1, 0) And _
ThisWorkbook.Sheets("Tabelle1").Cells(zeile, 4) = ThisWorkbook.Sheets("Tabelle1").Cells(zeile, 4).Offset(1, 0)
ThisWorkbook.Sheets("Tabelle1").Cells(zeile, 5) = ThisWorkbook.Sheets("Tabelle1").Cells(zeile, 5) & "&" & ThisWorkbook.Sheets("Tabelle1").Cells(zeile, 5).Offset(1, 0)
ThisWorkbook.Sheets("Tabelle1").Cells(zeile, 1).Offset(1, 0).EntireRow.Delete
Wend
zeile = zeile + 1
Wend
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

evt mußt Du die einträge "tabelle1" und die spaltennummern noch einmal anpassen.
de code läuft bei mir relativ schnell für die Spalten B-E
Gruß Ingo

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige