Spalten vergleichen, kopieren und einfügen

Moin,
nach langer Zeit muss ich euch noch einmal um Hilfe fragen. Das letzte Mal hattet ihr mir so super geholfen und ich hoffe, dass ihr mir wieder helfen könnt.
Es geht bei meinem Problem um folgenden Thread:
https://www.herber.de/forum/archiv/1708to1712/1708535_VBA__Spalten_vergleichen.html
Der Code hatte prima funktioniert, nur jetzt haben sich die Anforderungen etwas verändert und der Code bräuchte ein paar Anpassungen, die ich als Anfänger leider nicht implementieren konnte.
Zurzeit vergleicht das Makro die Daten aus Spalte mit E mit Spalte L und die Daten aus Spalte F mit Spalte M und wenn sich ein Eintrag bzw. beide Einträge unterscheiden, wird die betroffene Zeile kopiert, direkt unter der Zeile eingefügt und gelb markiert. Der Code steht im Makro in der Datei.
Nun gibt es drei neue Szenarien:
1. Wert in Spalte F stimmt nicht mit Spalte M überein: die Zeile soll zweimal kopiert und eingefügt werden, allerdings soll in der ersten eingefügten Zeile in Spalte F der Wert aus Spalte M und in der zweiten eingefügten Zeile in Spalte E der Wert aus Spalte M eingefügt werden. Idealerweise werden dann noch die Daten in der zweiten eingefügten Zeile in den Spalten L und M durch ein Minus ersetzt
2. Dieses Szenario gleicht im Grunde dem ersten Szenario, allerdings stimmt hier der Wert in Spalte E nicht mit dem Wert in Spalte L überein: die Zeile soll ebenfalls zweimal kopiert und darunter eingefügt werden, allerdings soll in der ersten eingefügten Zeile in Spalte F der Wert aus Spalte L und in der zweiten eingefügten Zeile in Spalte E der Wert aus spalte L eingefügt werden. Idealerweise werden dann noch die Daten in der ersten eingefügten Zeile in den Spalten L und M durch ein Minus ersetzt
3. Dieses Szenario ist etwas komplizierter. Hier stimmen die Werte in den Spalten E und F nicht mit den Werten in den Spalten L und M überein: die Zeile soll dreimal kopiert und eingefügt werden. In der ersten eingefügten Zeile soll in Spalte F der Wert aus Spalte L eingefügt werden. In der zweiten eingefügten Zeile soll in Spalte E der Wert aus Spalte L und in Spalte F der Wert aus Spalte M stehen. In der dritten Zeile soll in Spalte E der Wert aus Spalte M stehen. Und in diesem Szenario sollen idealerweise die Daten in der ersten und dritten Zeile in den Spalten L und M durch ein Minus ersetzt werden.
Die Beispieldatei ist unter folgendem Link zu finden:
https://www.herber.de/bbs/user/134572.xlsm
Im Arbeitsblatt Tabelle2 ist das Beispielergebnis für Tabelle1, wie es am Ende aussehen sollte. Die orangefarben markierten Zeilen sind die ursprünglichen Zeilen und die grün markierten Zeilen, das erhoffte Ergebnis.
Ich hoffe, dass das alles verständlich war und die Beispieldatei euren Ansprüchen genügt, sodass ihr mit dieser arbeiten könnt.
Vielen Dank im Voraus!
Viele Grüße
Tommy

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub vergleicheSpalten() 'Variablen definieren Dim i As Long Dim last As Long Dim neu As Long Dim obj_wks As Worksheet Dim strL As String, strM As String, strMinus As String 'Werte zuweisen Set obj_wks = ActiveSheet strMinus = "-" Application.ScreenUpdating = False With obj_wks last = .Cells(.Rows.Count, 2).End(xlUp).Row For i = last To 2 Step -1 strL = .Cells(i, 12).Text 'Wert in Spalte L strM = .Cells(i, 13).Text 'Wert in Spalte M 'prüfen Scenario 3 ' Werte in den Spalten E und F nicht mit den Werten in den Spalten L und M überein If Len(strL) > 1 And Len(strM) > 1 Then If (.Cells(i, 5) strL) And (.Cells(i, 6) strM) Then .Range(.Rows(i + 1), .Rows(i + 3)).Insert Shift:=xlDown neu = i + 1 .Rows(i).Copy .Range(.Rows(neu), .Rows(neu + 2)) .Range(.Cells(neu, 1), .Cells(neu + 2, 18)).Interior.ColorIndex = 6 '1. Zeile anpassen .Cells(neu, 6) = strL .Cells(neu, 12) = strMinus: .Cells(neu, 13) = strMinus '2. Zeile anpassen .Cells(neu + 1, 5) = strL: .Cells(neu + 1, 6) = strM '3. Zeile anpassen .Cells(neu + 2, 5) = strL .Cells(neu + 2, 12) = strMinus: .Cells(neu + 2, 13) = strMinus GoTo next_I End If End If 'prüfen Scenario 2 If Len(strL) > 1 Then If .Cells(i, 5) strL Then .Range(.Rows(i + 1), .Rows(i + 2)).Insert Shift:=xlDown neu = i + 1 .Rows(i).Copy .Range(.Rows(neu), .Rows(neu + 1)) .Range(.Cells(neu, 1), .Cells(neu + 1, 18)).Interior.ColorIndex = 6 '1. Zeile anpassen .Cells(neu, 6) = strL .Cells(neu, 12) = strMinus: .Cells(neu, 13) = strMinus '2. Zeile anpassen .Cells(neu + 1, 5) = strL GoTo next_I End If End If 'prüfen Scenario 1 If Len(strM) > 1 Then If .Cells(i, 6) strM Then .Range(.Rows(i + 1), .Rows(i + 2)).Insert Shift:=xlDown neu = i + 1 .Rows(i).Copy .Range(.Rows(neu), .Rows(neu + 1)) .Range(.Cells(neu, 1), .Cells(neu + 1, 18)).Interior.ColorIndex = 6 '1. Zeile anpassen .Cells(neu, 6) = strM '2. Zeile anpassen .Cells(neu + 1, 5) = strM .Cells(neu + 1, 12) = strMinus: .Cells(neu + 1, 13) = strMinus End If End If next_I: Next i End With Application.ScreenUpdating = True End Sub

Hallo Tommy,
hier das Makro mit den gewünschten Ergänzungen.
Der Wert für Spalte K wird dabei in einer separaten Funktion ermittelt.
LG
Franz

Sub vergleicheSpalten_neu()
'Variablen definieren
Dim i As Long
Dim last As Long
Dim neu As Long
Dim obj_wks As Worksheet
Dim strL As String, strM As String, strMinus As String
'Werte zuweisen
Set obj_wks = ActiveSheet
strMinus = "-"
Application.ScreenUpdating = False
With obj_wks
last = .Cells(.Rows.Count, 2).End(xlUp).Row
For i = last To 2 Step -1
strL = .Cells(i, 12).Text 'Wert in Spalte L
strM = .Cells(i, 13).Text 'Wert in Spalte M
'prüfen Scenario 3
' Werte in den Spalten E und F nicht mit den Werten in den Spalten L und M überein
If Len(strL) > 1 And Len(strM) > 1 Then
If (.Cells(i, 5)  strL) And (.Cells(i, 6)  strM) Then
.Range(.Rows(i + 1), .Rows(i + 3)).Insert Shift:=xlDown
neu = i + 1
.Rows(i).Copy .Range(.Rows(neu), .Rows(neu + 2))
.Range(.Cells(neu, 1), .Cells(neu + 2, 18)).Interior.ColorIndex = 6
'1. Zeile anpassen
.Cells(neu, 6) = strL
.Cells(neu, 12) = strMinus: .Cells(neu, 13) = strMinus
.Cells(neu, 11) = fncSpaK(.Cells(neu, 11), .Cells(neu, 13), _
.Cells(neu, 12), strMinus)
'2. Zeile anpassen
.Cells(neu + 1, 5) = strL: .Cells(neu + 1, 6) = strM
.Cells(neu + 1, 11) = fncSpaK(.Cells(neu + 1, 11), .Cells(neu + 1, 13), _
.Cells(neu + 1, 12), strMinus)
'3. Zeile anpassen
.Cells(neu + 2, 5) = .Cells(neu + 1, 13)
.Cells(neu + 2, 12) = strMinus: .Cells(neu + 2, 13) = strMinus
.Cells(neu + 2, 11) = fncSpaK(.Cells(neu + 2, 11), .Cells(neu + 2, 13), _
.Cells(neu + 2, 12), strMinus)
GoTo next_I
End If
End If
'prüfen Scenario 2
If Len(strL) > 1 Then
If .Cells(i, 5)  strL Then
.Range(.Rows(i + 1), .Rows(i + 2)).Insert Shift:=xlDown
neu = i + 1
.Rows(i).Copy .Range(.Rows(neu), .Rows(neu + 1))
.Range(.Cells(neu, 1), .Cells(neu + 1, 18)).Interior.ColorIndex = 6
'1. Zeile anpassen
.Cells(neu, 6) = strL
.Cells(neu, 12) = strMinus: .Cells(neu, 13) = strMinus
.Cells(neu, 11) = fncSpaK(.Cells(neu, 11), .Cells(neu, 13), _
.Cells(neu, 12), strMinus)
'2. Zeile anpassen
.Cells(neu + 1, 5) = strL
.Cells(neu + 1, 11) = fncSpaK(.Cells(neu + 1, 11), .Cells(neu + 1, 13), _
.Cells(neu + 1, 12), strMinus)
GoTo next_I
End If
End If
'prüfen Scenario 1
If Len(strM) > 1 Then
If .Cells(i, 6)  strM Then
.Range(.Rows(i + 1), .Rows(i + 2)).Insert Shift:=xlDown
neu = i + 1
.Rows(i).Copy .Range(.Rows(neu), .Rows(neu + 1))
.Range(.Cells(neu, 1), .Cells(neu + 1, 18)).Interior.ColorIndex = 6
'1. Zeile anpassen
.Cells(neu, 6) = strM
.Cells(neu, 11) = fncSpaK(.Cells(neu, 11), .Cells(neu, 13), _
.Cells(neu, 12), strMinus)
'2. Zeile anpassen
.Cells(neu + 1, 5) = strM
.Cells(neu + 1, 12) = strMinus: .Cells(neu + 1, 13) = strMinus
.Cells(neu + 1, 11) = fncSpaK(.Cells(neu + 1, 11), .Cells(neu + 1, 13), _
.Cells(neu + 1, 12), strMinus)
End If
End If
next_I:
Next i
End With
Application.ScreenUpdating = True
End Sub
Private Function fncSpaK(ByVal varSpaK, ByVal varSpaM, ByVal varSpaL, ByVal strMinus As String)  _
As Variant
fncSpaK = varSpaK
If varSpaM = strMinus And varSpaL = strMinus Then
fncSpaK = 0
ElseIf Len(varSpaM) > 1 And Len(varSpaL) > 1 Then
fncSpaK = 1
End If
End Function

Beliebteste Forumthreads (12 Monate)

Spalten vergleichen, kopieren und einfügen

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

325 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Spalten vergleichen, kopieren und einfügen

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

325 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread