Re: gleiche zellen nebeneinander setzen
22.11.2002 12:22:32
Ralf Sögel
Bei 25.000 Datensätzen solltest du etwas Geduld haben:Option Explicit
''Die Daten beginnen in Zelle A1, der Suchbegriff(AFNR) muss
''eine Ganzzahl sein, ansonsten die Variable SB als Variant oder
''als String deklarieren!
''Der Code sollte nur einmalig ausgeführt werden, da ich auf
''eine Überprüfung verzichtet habe.
Sub zusammenfassen()
Dim SB As Long ''Suchbegriff ggf. als Variant oder String deklarieren!
Dim WSH As Worksheet, LZ As Long, Z As Long, ZZ As Long
Dim X As Long, S As Integer, NZ As Long
''Tabellenname ggf. anpassen!
Set WSH = ThisWorkbook.Sheets("Tabelle1")
LZ = WSH.[a65536].End(xlUp).Row
If LZ = 1 Then Exit Sub
ZZ = 1
S = 3
X = 1
NZ = 1
''Code beschleunigen
With Application
.ScreenUpdating = False
.Calculation = xlManual
End With
''Erstmal sortieren, falls noch nicht sortiert ist.
WSH.Columns("A:IV").Sort Key1:=WSH.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
For Z = 1 To LZ
ZZ = ZZ + 1
''SB muss Ganzzahl sein oder siehe weiter oben!
SB = Cells(ZZ, 1).Value
While Cells(ZZ, 1).Value = SB And X < LZ
WSH.Cells(NZ, S) = WSH.Cells(ZZ, 2)
WSH.Rows(ZZ).ClearContents
''Falls die max. Anzahl der Spalten überschritten wird!
If S <= 256 Then
S = S + 1
Else
MsgBox "Maximum von 256 Spalten erreicht!" & Space(10), 64, "weise hin..."
Set WSH = Nothing
Exit Sub
End If
ZZ = ZZ + 1
X = X + 1
Wend
S = 3
NZ = Z + X
If ZZ >= LZ Then Exit For
Next
''Sortieren, um Leerzeilen zu entfernen.
WSH.Columns("A:IV").Sort Key1:=WSH.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
End With
''Objektvariable löschen
Set WSH = Nothing
End Sub