Blockweises Verschieben

Hallo Community,
ich will die ersten beiden Spalten zweier Blöcke nach folgenden 4 Bedingungen jeweils miteinander vergleichen und dementsprechen sortieren.
Startzelle z.B. C15
1. Wenn in Zelle C15 Hinweis steht und im rechten Block in Zelle F15 eine Zahl, schiebe alle Werte im rechten Block eine Zeile nach unten
2. Wenn in Zelle C15 Hinweis steht und im rechten Block Zelle F15 ebensfalls Hinweis verschiebe den Block auf beiden Seiten nicht
3. Wenn in Zelle C15 eine Zahl enthalten ist, prüfe ob in Spalte F vorhanden ist und verschiebe anschließend den ganzen Block darunter auf die richtige Zeile wo beide Werte gleich sind
4. Ist in Zelle C15 eine Zahl entalten aber nicht im Spalte F vorhanden, verschiebe den rechten Block eine Zeile nach unten
Nachdem die Prüfung für Zelle C15 abgeschlossen ist, wird eine Zeile runtergesprungen in D15 und die gleichen Schritte werden ebensfalls angewendet...
Das ganze als Schleife bis die Tabelle endet oder ggf. Zeile 9999
Ziel ist es so 2 Blöcke die durch hinzufügen von Zeilen wieder auf gleiche Höhe zu bringen und die einzelnen Zeilen miteinander vergleichen zu können
Damit es ganze verständlicher ist, habe ich in der beigefügten Excel Beispiele aufgezeigt wie das ganze gemeint ist.
Wäre super, wenn mir hierzu jemand kurz ein Makro schreiben könnte =)
Würde mir meine alltägliche Arbeit immens erleichtern.
https://www.herber.de/bbs/user/125159.xlsx

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Tommich,
wenn ich dein Problem richtig verstanden habe, dann kannst du es mit dem folgenden Programm lösen:

Sub Verschieben()
Dim letzteZeileC As Long
Dim letzteZeileF As Long
Dim i As Long
Dim suchBereich As Range
Dim suchErgebnis As Object
Dim ws As Worksheet
Dim zahl As Long
Dim zeile As Long
Dim zeileGefunden As Long
Dim zeilenDifferenz As Long
Set ws = ThisWorkbook.Worksheets(1)
letzteZeileC = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
If letzteZeileC  letzteZeileC
If ws.Cells(zeile, "C") = "Hinweis" And _
IsNumeric(ws.Cells(zeile, "F")) Then
' Fall 1
ws.Cells(zeile, "F").Resize(1, 3).Insert Shift:=xlDown
letzteZeileF = letzteZeileF + 1
ElseIf IsNumeric(ws.Cells(zeile, "C")) Then
' Suchen
Set suchBereich = ws.Range(ws.Cells(zeile, "F"), _
ws.Cells(letzteZeileF, "F"))
Set suchErgebnis = suchBereich.Find(What:=ws.Cells(zeile, "C"))
zeileGefunden = 0
If Not suchErgebnis Is Nothing Then
zeileGefunden = suchErgebnis.Row
End If
If zeileGefunden > 0 Then
' Fall 3
zeilenDifferenz = zeileGefunden - zeile
For i = 1 To zeilenDifferenz
ws.Cells(zeile, "C").Resize(1, 3).Insert Shift:=xlDown
Next i
zeile = zeile + zeilenDifferenz
letzteZeileC = letzteZeileC + zeilenDifferenz
Else
' Fall 4
ws.Cells(zeile, "F").Resize(1, 3).Insert Shift:=xlDown
letzteZeileF = letzteZeileF + 1
End If
End If
zeile = zeile + 1
Loop
End Sub

https://www.herber.de/bbs/user/125245.xlsm
Falls ich dich nicht richtig verstanden habe, dann gib doch bitte ein paar zusätzliche Erläuterungen und zugehöriges Beispielmaterial.
Viele Grüße
Dieter

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread