Excel VBA Markierte Zeilen verschieben

[Gast 123]

Hallo

hier noch ein excellenter Code um MergeCells zu verschieben mit einigen Warnmeldungen bei Unstimmigkeiten.
Warum klappte es nicht über den bisherigen Code??   Weil Excel nun mal sehr penibel in den Code Details ist!!


Mehrfach schlug mein Code fehl, kam eine DialogBox das Excel die verknüpften Zellen auflösen will!  Jedesmal Murks.
Bis ich begriff das man nicht die LastZell in Tabelle Abtragen suchen muss, sondern auch noch die Laenge der MergeCells feststellen und bei der Festlegung von LastZell zum Einfügen berücksichtigen muss. Dann klappt das verschieben auch!

mfg Gast 123

Code:

Sub MergeCells_verschieben()
Dim rw As Long, rx As Integer, Bereich As String
Dim lz1 As Long, lz2 As Long, lrx As Integer
If ActiveSheet.Name <> "Karte" Then Exit Sub
rw = ActiveCell.Row
rx = ActiveCell.MergeArea.Rows.Count - 1
lz1 = Sheets("Abgetragen").Cells(Rows.Count, 1).End(xlUp).Row
lz2 = Sheets("Abgetragen").Cells(Rows.Count, 2).End(xlUp).Row
lrx = Sheets("Abgetragen").Cells(lz2, 1).MergeArea.Rows.Count
If rw < 10 Then MsgBox "Ungültige Zeile < 10": Exit Sub
If Cells(rw, 1).Value = Empty Then MsgBox "Datum fehlt!!": Exit Sub
If lz1 <> lz2 Then MsgBox "Unstimmige Endzeile in Abgetragen": Exit Sub
'Cut Bereich über NergeCells festlegen
Bereich = rw & ":" & rw + rx
'Ziel Row über lrx festlegen  (MergeCells berücksichtigen!)
Sheets("Karte").Rows(Bereich).Cut _
Sheets("Abgetragen").Rows(lz1 + lrx)
ActiveCell.Select
End

[snb]

@Gas
Ein einszeiler reicht:

Code:

Sub M_snb()
  Sheet1.Cells(Rows.Count, 6).End(xlUp).Offset(2, -5).Resize(2, 15).Value = ActiveCell.MergeArea.Resize(, 15).Value
End Sub

Doch:
- verzichte auf verbundene Zellen.
- verzichte auf redundante Vorgehensweisen:
   In Tabbelle 1
   Daten in Database Form  und eine Spalte zum markieren was 'abgetragen' ist.

[Marko120586]

Hallo Jungs,

Danke für diese vielen Ansätze und Lösungen.
Ich habe hierfür einen Kompromiss gefunden und nicht notwendige zellverbindungen
Gelöst. So klappt der Lösungsansatz von HKindler einwandfrei.

Ich danke euch nochmals für die hilfreichen Tipps

Gruß Marko