Clever-Excel-Forum

Seiten: 1 2

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

@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.

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

Seiten: 1 2

Gast 123

snb

Marko120586