kleiner Fehler
26.07.2010 12:13:26
JogyB
Hallo Markus,
da war ein kleiner Fehler drin. Wenn zwischen zwei Bereichen keine Leerzeile ist und es noch weitere Bereich gibt, dann funktioniert es nicht richtig.
Sub ZellCopy()
Dim arNr As Long
With ActiveCell
.Value = .Offset(-1, 0)
End With
With Selection
' Nächste Zelle ist in der nachfolgenden Zelle derselben Spalte
If Not Intersect(Selection, ActiveCell.Offset(0, 1)) Is Nothing Then
ActiveCell.Offset(0, 1).Activate
' Es gibt eine Zelle in der darauffolgenden Zeile und nur einen ausgewählten Bereich
ElseIf Not Intersect(Selection, ActiveCell.Offset(1, 0).EntireRow) Is Nothing _
And .Areas.Count = 1 Then
Intersect(Selection, ActiveCell.Offset(1, 0).EntireRow).Cells(1, 1).Activate
' Mehrere Bereiche sind ausgewählt
ElseIf .Areas.Count > 1 Then
' ausgewählten Bereich bestimmen
For arNr = 1 To .Areas.Count
If Not Intersect(.Areas(arNr), ActiveCell) Is Nothing Then
Exit For
End If
Next
' Nun schauen, ob dieser Bereich eine Zelle in der nächsten Zeile hat
' Falls ja, dann erste Zelle diese Zelle aus dem Bereich auswählen
If Not Intersect(.Areas(arNr), ActiveCell.Offset(1, 0).EntireRow) Is Nothing Then
Intersect(.Areas(arNr), ActiveCell.Offset(1, 0).EntireRow).Cells(1, 1).Activate
' Falls nein, in nächsten Bereich wechseln
Else
arNr = IIf(arNr = .Areas.Count, 1, arNr + 1)
.Areas(arNr).Cells(1, 1).Activate
End If
' Sonst wieder erste Zelle der Auswahl
Else
.Cells(1, 1).Activate
End If
End With
End Sub
Gruß, Jogy