Makro Zeilenblock verschieben

Guten Morgen liebe Leute.
Ich hätte ein großes Problem.
Ich soll aus einem generierten Report aus einem ERP System einen verwertbaren Bericht in Excel machen und dazu muss ich einige Sachen ändern.
Da nun aber nicht alle Zellen zu den jeweiligen Überschriften passen, wollte ich mir da mit einem Marko helfen, denn der Bericht wird mich öfter heimsuchen.
Mein Problem ist nun folgendes
Ein Teil der Daten ist um je 2 Zeilen versetzt, da die Daten variieren kann ich nicht immer die gleichen Zellen verschieben, aber dies lässt sich mit Strg und nach unten in der Spalte (CB) sehr gut rausfinden.
Wenn ich nun die Reihe habe, muss ich 7x (Strg und links) drücken und dann den markierten Block um 2 Spalten nach links schieben. Nun habe ich aber das Problem, dass mir das makro die aktiven Zeilen nicht nehmen will.
Ich habe mich mal in VBA versucht und bin aber zu keinem Ergebnis gekommen.
So sieht mal mein Versuch aus:
Columns("BK:CC").Select
Selection.UnMerge
Range("CB3").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlDown)).Select (Markieren des Zeilenblocks)
Range(Selection, Selection.End(xlToLeft)).Select (7x nach links)
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Selection.Cut Destination:=Range(Selection, Selection).Select (dort soll er die aktiven Zellen ausschneiden)
Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row - 2)).Select (und hierhin verschieben)
Für eure hilfe wäre ich äußerst dankbar.
Beste Grüße
Florian

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub format_Korrektur() Dim myRng As Range Dim i As Long With ActiveSheet For i = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Row ' Überprüft, ob in der Zelle was verbunden ist If .Rows(i).MergeCells Or VarType(Rows(i).MergeCells) = vbNull Then ' Speichert die entsprechenden Zeilen zwischen If myRng Is Nothing Then Set myRng = .Rows(i) Else Set myRng = Union(myRng, Rows(i)) End If End If Next ' Wenn es verbundene Zellen gab If Not myRng Is Nothing Then ' Verbund auflösen myRng.UnMerge ' dadurch sind leere Zellen entstanden, die nun löschen Intersect(.UsedRange, myRng).SpecialCells(xlCellTypeBlanks).Delete _ Shift:=xlShiftToLeft End If End With End Sub

Hallo Florian,
das hat jetzt leider auch nicht im Detail beantwortet, was ich wissen wollte, mir ging es konkret um die verbundenen Zellen im relevanten Bereich.
Ok, ich habe das jetzt auf die Spalten BK bis BM eingeshränkt. Formuliert ist der Code allgemeiner, aber so hatte ich ihn jetzt schon fertig (könnte man durch die Einschränkungen wohl kürzer machen, die Laufzeit tendiert aber eh gegen null). Bei leeren verbundenen Zellen in dem Bereich bleibt immer eine stehen.

Sub format_Korrektur()
Dim zeLLe As Range
Dim rowArr() As Long
Dim delRange As Range
Dim i As Long
Dim k As Long
Dim suchRange As Range
ReDim rowArr(0 To 0)
With ActiveSheet
Set suchRange = Range(.Columns(63), Columns(65))
For i = 2 To .Cells.SpecialCells(xlCellTypeLastCell).Row
' Überprüft, ob in der Zelle was verbunden ist
If Intersect(.Rows(i), suchRange).MergeCells Or _
VarType(Intersect(.Rows(i), suchRange).MergeCells) = vbNull Then
' Speichert die entsprechenden Zeilen zwischen
If UBound(rowArr) = 0 Then
ReDim rowArr(1 To 1)
rowArr(1) = i
Else
ReDim Preserve rowArr(1 To UBound(rowArr) + 1)
rowArr(UBound(rowArr)) = i
End If
End If
Next
' Wenn es verbundene Zellen gab
If UBound(rowArr) > 0 Then
For i = 1 To UBound(rowArr)
For Each zeLLe In Intersect(.UsedRange, .Rows(rowArr(i)), suchRange)
With zeLLe
If .MergeCells And .Address = .MergeArea.Cells(1, 1).Address Then
If delRange Is Nothing Then
Set delRange = Range(Cells(.Row, .Column + 1), _
Cells(.Row, .Column + zeLLe.MergeArea.Columns.Count - 1))
Else
Set delRange = Union(delRange, _
Range(Cells(.Row, .Column + 1), _
Cells(.Row, .Column + zeLLe.MergeArea.Columns.Count - 1)))
End If
End If
End With
Next
Next
' Verbund aufheben
' geht über delrange, da fehlt zwar immer die erste Zelle
' funktioniert aber trotzdem
delRange.UnMerge
delRange.Delete Shift:=xlShiftToLeft
End If
End With
End Sub

Gruß, Jogy

Sub format_Korrektur2() Dim myRng As Range Dim suchRng As Range Dim i As Long With ActiveSheet For Each suchRng In Intersect(.Columns(64), .UsedRange) ' Überprüft, ob in der Zelle was verbunden ist If suchRng.MergeCells Or _ VarType(suchRng.MergeCells) = vbNull Then ' Speichert die entsprechenden Zeilen zwischen If myRng Is Nothing Then Set myRng = suchRng Else Set myRng = Union(myRng, suchRng) End If End If Next ' Wenn es verbundene Zellen gab If Not myRng Is Nothing Then ' Verbund auflösen myRng.UnMerge ' dadurch sind leere Zellen entstanden, die nun löschen Union(myRng, myRng.Offset(0, 1)).SpecialCells(xlCellTypeBlanks).Delete _ Shift:=xlShiftToLeft End If End With End Sub

Beliebteste Forumthreads (12 Monate)

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread