Bereich verschieben
27.10.2009 19:46:29
Erich
Hi,
so klappt das aber nur unter "guten" Bedingungen - wenn sich Quell- und Zielbereich nicht überlappen.
Im folgenden Beispiel geht das schief:
Wenn A1:A2 selektiert ist, wird der Bereich mit
.Copy Selection.Offset(1, 0)
auf A2:A3 kopiert - so weit, so gut. Dann aber wird A1:A2 mit .ClearContents gelöscht - auch A2.
Das soll sicher nicht sein, man darf nur den Teil der Selection leeren, in den nicht kopiert wurde.
Das könnte so gehen:
(Hier kann auch noch gewählt werden, ob gelöscht werden soll (also kopiert oder verschoben)
und ob der Zielbereich selektiert werden soll.)
Option Explicit
Sub aTestA()
RngMove Selection, 1, 1, True, True
End Sub
Sub aTestB()
RngMove Selection, -1, -1, True, True
End Sub
' kopiert/verschiebt einen Bereich um Zeilen/Spalten
Sub RngMove(rngB As Range, lngRows As Long, lngCols As Long, _
bolDel As Boolean, bolSel As Boolean)
Dim rngNeu As Range, rngDif As Range
With rngB
Set rngNeu = .Offset(lngRows, lngCols)
.Copy rngNeu
If bolDel Then
Set rngDif = Intersect(rngB, ComplRect(rngNeu))
If Not rngDif Is Nothing Then rngDif.Clear
End If
If bolSel Then rngNeu.Select
End With
End Sub
' Komplement eines Rechteck-Bereichs zurück
Function ComplRect(rngA As Range) As Range
Dim zv As Long, zb As Long, sv As Long, sb As Long, rngT As Range
zv = rngA.Row: zb = zv + rngA.Rows.Count - 1
sv = rngA.Column: sb = sv + rngA.Columns.Count - 1
If zv > 1 Then Set rngT = Range(Rows(1), Rows(zv - 1))
If zb 1 Then
If rngT Is Nothing Then
Set rngT = Range(Cells(zv, 1), Cells(zb, sv - 1))
Else
Set rngT = Union(rngT, Range(Cells(zv, 1), Cells(zb, sv - 1)))
End If
End If
If sb
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort