Hi,
Option Explicit
Sub Zusammenfügen()
Dim V, a&, b&, c&, E&, Zeile(), AlleZeilen(), temp
Dim CopyRow As Boolean
With ActiveSheet
V = .Range(.Cells(.Rows.Count, 1).End(xlUp), .Cells(1, 2)).Value
End With
E = UBound(V)
b = 2
ReDim Zeile(0, b)
For a = 2 To E
If V(a - 1, 1) = V(a, 1) Then
ReDim Preserve Zeile(0, b)
Zeile(0, 0) = V(a, 1)
Zeile(0, b - 1) = V(a - 1, 2)
Zeile(0, b) = V(a, 2)
b = b + 1
Else
CopyRow = True
End If
If CopyRow Or E = a Then
If b = 2 Then
ReDim Zeile(0, 2)
Zeile(0, 0) = V(a - 1, 1)
Zeile(0, 1) = V(a - 1, 2)
Else
b = 2
End If
ReDim Preserve AlleZeilen(c)
AlleZeilen(c) = Zeile
c = c + 1
CopyRow = False
End If
Next
If V(E - 1, 1) <> V(E, 1) Then
ReDim Zeile(0, 2)
Zeile(0, 0) = V(E, 1)
Zeile(0, 1) = V(E, 2)
ReDim Preserve AlleZeilen(c)
AlleZeilen(c) = Zeile
c = c + 1
End If
'out
With ActiveSheet
For a = 0 To c - 1
.Range(.Cells(1 + a, 10), .Cells(1 + a, 10 + UBound(AlleZeilen(a), 2))) = AlleZeilen(a)
Next
End With
End Sub
Eigentlich war ich der Meinung das müsste recht einfach gehen, mir fällt allerdings grade nichts besseres ein... ist etwas komplizierter geworden. Man kann das sicherlich auch anders lösen.
Gruß
Till
|