Optimiert
06.03.2016 17:45:53
Michael
Hallo zusammen,
der Thread ist geschlossen, dennoch nimmt er die Antwort vielleicht noch an...
Ich habe das Ding noch optimiert und die Bearbeitung auf 2 Sekunden gedrückt.
Das Makro:
Option Explicit
Sub GanzNeu()
Dim a As Variant, b As Variant, c As Variant
Dim i&, j&, k&, maxz&, z&
Dim letzter
Dim s$
Dim gefunden As Boolean
Dim shO As Worksheet, shT As Worksheet
Dim maxw&, w&
Dim t As Single
t = Timer
Set shO = Sheets("Original")
Set shT = Sheets("Test2")
shT.Cells.Clear
maxz = shO.Range("A" & shO.Rows.Count).End(xlUp).Row
shO.Range("A1").CurrentRegion.Copy shT.Range("A1")
Application.CutCopyMode = False
'shT.Range("A1").CurrentRegion.RemoveDuplicates _
' Columns:=Array(1, 2, 3, 4), Header:=xlYes
shT.Range("A1").CurrentRegion.RemoveDuplicates _
Columns:=1, Header:=xlYes
a = shO.Range("A1:A" & maxz + 1)
b = shO.Range("G1:Q" & maxz + 1)
c = shO.Range("R1:R" & maxz + 1) ' muß eine leere Spalte sein, evtl. weiter rechts
s = ""
z = 3
gefunden = False
letzter = -1
maxw = 0
For i = 3 To maxz
If a(i, 1) = letzter Then
gefunden = True
If w = 0 Then
For k = 1 To 11
If b(i - 1, k) "" Then
w = w + 1
Else
Exit For
End If
Next
End If
For k = 1 To 11
If b(i, k) "" Then
s = s & "'" & b(i, k) & "!"
Else
Exit For
End If
Next
' Stop
Else
If gefunden Then
' Stop
c(z - 1, 1) = s
s = ""
a(z - 1, 1) = w
w = 0
End If
z = z + 1
gefunden = False
End If
letzter = a(i, 1)
a(i, 1) = 0
Next
'shT.Range("R1:R" & z) = c
'shT.Range("S1:S" & z) = a
'MsgBox ""
For k = 2 To z
If c(k, 1) "" Then
b = Split(c(k, 1), "!")
If UBound(b) > 0 Then
shT.Cells(k, a(k, 1) + 7).Resize(1, UBound(b)) = b
End If
End If
Next
MsgBox (Timer - t) * 1000 & "ms"
End Sub
Unausgesprochene Voraussetzung: die Daten sind nach Spalte A sortiert.
Schöne Grüße,
Michael