Korrektur
29.06.2009 17:07:33
Jogy
Da haben sich zwei kleine Fehler eingeschlichen:
Sub verBinden()
Dim myAdr() As String
Dim i As Long
Dim maxCell As Long
Dim lastArea As Range
With ActiveSheet
' Liest die Adressen der Leerzeilen aus und schreibt sie in einen Array
myAdr = Split(.Range(.Cells(2, 8), .Cells(2, .Columns.Count)).SpecialCells( _
xlCellTypeBlanks).Address, ",")
' Bis zur vorletzten befüllten Zelle alles verbinden
For i = 0 To UBound(myAdr) - 1
.Range(myAdr(i)).Offset(0, -1).Resize(1, .Range(myAdr(i)).Columns.Count + 1). _
MergeCells = True
Next
' Spezial für letzte befüllte Zelle
' Das kann je nach Struktur auch die vorletzte befüllte Zelle sein,
' muss also geprüft werden
If .Cells(2, Range(myAdr(i)).Column + Range(myAdr(i)).Columns.Count) = "" Then
' Ist wirklich die letzte
' Bereich bis zur letzten Zelle in Zeile 3 verkleinern
' Wenn die erste Zelle schon rechts davon liegt, dann gibt es einen Fehler
' und nichts passiert
' Hinweis: i steht auf Ubound(myAdr)
On Error Resume Next
.Range(myAdr(i)).Offset(0, -1).Resize(1, .Cells(3, Columns.Count).End(xlToLeft). _
Column - .Range(myAdr(i)).Column + 2).MergeCells = True
On Error GoTo 0
Else
' Ist die vorletzte, also kompletten Bereich verbinden
.Range(myAdr(i)).Offset(0, -1).Resize(1, .Range(myAdr(i)).Columns.Count + 1). _
MergeCells = True
End If
End With
End Sub
So sollte es jetzt passen.
Gruss, Jogy