VBA - Spalten vergleichen | HERBERS Excel Forum

Guten Tag in die Runde,
ich bin neu im Forum und ein absoluter Anfänger was VBA angeht, aber vielleicht kann mir ja jemand helfen.
Ich habe folgendes Problem: Ich möchte je zwei Spalten miteinander vergleichen. Spalte A soll mit Spalte C und Spalte B soll mit Spalte D verglichen werden.
In den Spalten A und B stehen immer Buchstabenkombinationen, bspw. in Spalte A "TDE" und in Spalte B "BUH". In den Spalten C und D stehen meistens lediglich "-", diese Zeilen sollen nicht weiter beachtet werden. Nur wenn in einer Zeile der Spalten C und D eine Buchstabenkombination steht und diese Buchstabenkombination sich von der Kombination in Spalte A oder B unterscheidet, soll die gesamte Zeile kopiert, direkt darunter eingefügt und farblich markiert werden.
Also bspw. steht in der 15. Zeile der Spalte A "TDE", in Spalte B "BUH", in Spalte C "TDE" aber in Spalte D "KAR". Da die Zeile der Spalte B =! D ist, müsste die gesamte Zeile kopiert und farblich markiert werden.
Über Hilfe wäre ich sehr dankbar.
Folgenden Programmcode habe ich bisher geschrieben, aber der funktioniert leider nicht:

Sub vergleicheSpalten()
'Variablen definieren
Dim i As Integer
Dim last As Integer
'Werte zuweisen
last = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
Range(A1, D4).Activate
With ActiveCell.CurrentRegion
For i = 1 To (last - 1)
If A.i  C.i Or B.i  D.i Then
' hier soll eine Zeile hinzugefügt werden
Rows("i:1").Select
Selection.Insert Shift:=xlDown
'hier soll eine Zeile kopiert werden
.Range("i-1:1").Copy
Destination:=.Range("i:1")
'hier soll die Zeile gefärbt werden
.Rows(i).Interior.ColorIndex = 3
Else
End If
End Sub

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 'Werte zuweisen Set obj_wks = ActiveSheet last = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row neu = last + 1 With obj_wks For i = 1 To last If Len(.Cells(i, 3)) > 1 Then If (.Cells(i, 1) .Cells(i, 3)) Or (.Cells(i, 2) .Cells(i, 4)) Then .Rows(i).Copy Cells(neu, 1) .Range("A" & neu & ":D" & neu).Interior.ColorIndex = 3 neu = neu + 1 End If End If Next End With End Sub

Sub vergleicheSpalten() 'Variablen definieren Dim i As Long Dim last As Long Dim neu As Long Dim obj_wks As Worksheet 'Werte zuweisen Set obj_wks = ActiveSheet last = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row neu = last + 1 With obj_wks For i = 2 To last If Len(.Cells(i, 12)) > 1 Then If (.Cells(i, 5) .Cells(i, 12)) Or (.Cells(i, 6) .Cells(i, 13)) Then .Rows(i).Copy Cells(neu, 1) .Range("A" & neu & ":D" & neu).Interior.ColorIndex = 3 neu = neu + 1 End If End If Next End With End Sub

Sub test() With ActiveSheet.UsedRange With .Columns(.Columns.Count + 1) .FormulaR1C1 = "=IF(RC12=""-"","""",IF(COUNTIFS(C5,RC12,C6,RC13)=0,1,""""))" .Formula = .Value .Cells(1, 1).ClearContents If WorksheetFunction.Sum(.Cells) > 1 Then With Intersect(Range(Columns(1), .Offset(0, -1)), _ .SpecialCells(xlCellTypeConstants, 1).EntireRow) .Interior.Color = vbGreen .Copy Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll End With End If .EntireColumn.ClearContents End With End With End Sub

Sub test() With ActiveSheet.UsedRange With .Columns(.Columns.Count + 1).Resize(, 2) .Columns(1).Formula = "=Row()" .Columns(2).FormulaR1C1 = "=IF(RC12=""-"","""",IF(COUNTIFS(C5,RC12,C6,RC13)=0,1,""""))" .Formula = .Value .Cells(1, 2).ClearContents If WorksheetFunction.Sum(.Columns(2)) > 1 Then With Intersect(.Columns(2).SpecialCells(xlCellTypeConstants, 1).EntireRow, _ ActiveSheet.UsedRange) .Copy Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll End With Selection.Interior.Color = vbGreen ActiveSheet.UsedRange.Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes End If .EntireColumn.ClearContents End With End With End Sub

Sub vergleicheSpalten() 'Variablen definieren Dim i As Long Dim last As Long Dim neu As Long Dim obj_wks As Worksheet 'Werte zuweisen Set obj_wks = ActiveSheet last = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row neu = last + 1 With obj_wks For i = 2 To last If Len(.Cells(i, 12)) > 1 Then If (.Cells(i, 5) .Cells(i, 12)) Or (.Cells(i, 6) .Cells(i, 13)) Then .Rows(i).Copy Cells(neu, 1) .Range("A" & neu & ":R" & neu).Interior.ColorIndex = 6 neu = neu + 1 End If Selection.Interior.ColorIndex = 6 End If Next .UsedRange.Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes End With End Sub

Hallo Regina,
das funktioniert schon wesentlich besser als das, was ich bisher zustande gebracht habe. Ich habe nur noch eine Frage dazu.
In Spalte A steht ja das Datum und wenn bspw. der 01.08.2019 Einträge über acht Zeilen hat, und von diesen acht Zeilen lediglich die erste Zeile kopiert werden soll, dann kopiert er diese und fügt sie jetzt nicht mehr ans Ende der Tabelle hinzu, sondern immer ans Ende des jeweiligen Tages. Das passiert für alle Tage identisch, egal wie viel kopiert werden soll, die Kopien eines betroffenen Tages werden zusammengefasst ans Ende des jeweiligen Tages angefügt. Ich versuche aber, dass jede kopierte Zeile direkt unter die zu kopierende Zeile eingefügt wird.
Mit dem Code von Daniel hat das Sortieren ganz gut funktioniert, aber irgendwie läuft der Code leider sonst nicht so rund bei mir und würde lieber bei deinem bleiben, da er stabiler läuft.
Gruß
Tommy

Sub vergleicheSpalten() 'Variablen definieren Dim i As Long Dim last As Long Dim neu As Long Dim obj_wks As Worksheet 'Werte zuweisen Set obj_wks = ActiveSheet last = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row With obj_wks For i = 2 To last If Len(.Cells(i, 12)) > 1 Then If (.Cells(i, 5) .Cells(i, 12)) Or (.Cells(i, 6) .Cells(i, 13)) Then .Rows(i + 1).Insert Shift:=xlDown neu = i + 1 .Rows(i).Copy Cells(neu, 1) .Range("A" & neu & ":R" & neu).Interior.ColorIndex = 6 i = i + 1 End If End If Next End With End Sub

Sub vergleicheSpalten() 'Variablen definieren Dim i As Long Dim last As Long Dim neu As Long Dim obj_wks As Worksheet 'Werte zuweisen Set obj_wks = ActiveSheet last = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row i = 2 With obj_wks Do Until i > last If Len(.Cells(i, 12)) > 1 Then If (.Cells(i, 5) .Cells(i, 12)) Or (.Cells(i, 6) .Cells(i, 13)) Then .Rows(i + 1).Insert Shift:=xlDown neu = i + 1 .Rows(i).Copy Cells(neu, 1) .Range("A" & neu & ":R" & neu).Interior.ColorIndex = 6 i = i + 1 last = last + 1 End If End If i = i + 1 Loop End With End Sub

Beliebteste Forumthreads (12 Monate)

VBA - Spalten vergleichen

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread