2 Tabellen auf Werte vergleichen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Vergleichen() Dim lngZMaxA As Long Dim lngZMaxB As Long Dim y As Long Dim wksBlatt As Worksheet Set wksBlatt = ThisWorkbook.Worksheets("Tabelle3") 'Tabellenblatt anpassen y = 1 With wksBlatt lngZMaxA = .Cells(.Rows.Count, 1).End(xlUp).Row 'Maximale Länge Spalte A bestimmen lngZMaxB = .Cells(.Rows.Count, 2).End(xlUp).Row 'Maximale Länge Spalte B bestimmen If lngZMaxA > lngZMaxB Then For i = lngZMaxB To lngZMaxA .Cells(y, 6).Value = .Cells(i + 1, 1).Value 'Differenzwerte werden in Spalte 6 _ ab Zeile 1 geschrieben ggf. anpassen y = y + 1 Next i Else For i = lngZMaxA To lngZMaxB .Cells(y, 7).Value = .Cells(i + 1, 2).Value 'Differenzwerte werden in Spalte 7 _ ab Zeile 1 geschrieben ggf. anpassen y = y + 1 Next i End If End With End Sub

Moin Anton und vielen Dank für deine Antwort.


Sub Vergleichen()
Dim lngZMaxA As Long
Dim lngZMaxB As Long
Dim y As Long
Dim wksBlatt As Worksheet
Set wksBlatt = ThisWorkbook.Worksheets("Tabelle1") 'Tabellenblatt anpassen
y = 3
With wksBlatt
lngZMaxA = .Cells(.Rows.Count, 2).End(xlUp).row 'Maximale Länge Spalte B bestimmen
lngZMaxB = .Cells(.Rows.Count, 4).End(xlUp).row 'Maximale Länge Spalte D bestimmen
If lngZMaxA > lngZMaxB Then
For i = lngZMaxB To lngZMaxA
.Cells(y, 6).Value = .Cells(i + 1, 1).Value 'Differenzwerte werden in Spalte 6  _
_
ab Zeile 3 geschrieben ggf. anpassen
y = y + 1
Next i
Else
' do nothing
End If
End With
End Sub

Ich möchte im Grunde 2 Spalten miteinander vergleichen und wenn die Materialnummern in irgendeiner Zelle voneinander abweichen, sollen diese Werte in eine Spalte geschrieben werden. Ich habe deinen Code mal ein wenig angepasst (Leider klappt er noch nicht) und eine Beispieldatei hochgeladen. In Tabelle 1 sind die Daten. Vielen Dank für deine Mühen :)
https://www.herber.de/bbs/user/112348.xlsm

Sub A_B() Dim EndeA As Integer, EndeB As Integer, ZeileA As Integer, ZeileB As Integer, ZeileC As _ Integer, Gefunden As Range Application.ScreenUpdating = False ' Abschalten Bildschirmaktualisierung Columns(5).Clear EndeA = Range("A1").End(xlDown).Row EndeB = Range("B1").End(xlDown).Row ZeileC = 1 If EndeA > EndeB Then Cells(1, 4) = "Fehlt in B" For ZeileA = 1 To EndeA With Range(Cells(1, 2), Cells(EndeB, 2)) Set Gefunden = .Find(Cells(ZeileA, 1), , xlValues, xlWhole) End With If Gefunden Is Nothing Then Cells(ZeileC, 5) = Cells(ZeileA, 1) ZeileC = ZeileC + 1 End If Next ZeileA Else Cells(1, 4) = "Fehlt in A" For ZeileB = 1 To EndeB With Range(Cells(1, 1), Cells(EndeA, 1)) Set Gefunden = .Find(Cells(ZeileB, 2), , xlValues, xlWhole) End With If Gefunden Is Nothing Then Cells(ZeileC, 5) = Cells(ZeileB, 2) ZeileC = ZeileC + 1 End If Next ZeileB End If Application.ScreenUpdating = True ' Einschalten Bildschirmaktualisierung End Sub

Sub Vergleich() Dim strSuche As String Dim i As Long Dim x As Long Dim lastRowB As Long Dim lastRowD As Long lastRowB = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row lastRowD = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For i = 3 To lastRowB strSuche = Range("B" & i).Value Range("F" & Cells(Rows.Count, "F").End(xlUp).Row + 1) = strSuche For x = 3 To lastRowD If Range("D" & x) = strSuche Then Range("F" & Cells(Rows.Count, "F").End(xlUp).Row).ClearContents Exit For End If Next x Next i For i = 3 To lastRowD strSuche = Range("D" & i).Value Range("F" & Cells(Rows.Count, "F").End(xlUp).Row + 1) = strSuche For x = 3 To lastRowB If Range("B" & x) = strSuche Then Range("F" & Cells(Rows.Count, "F").End(xlUp).Row).ClearContents Exit For End If Next x Next i Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

Sub Vergleich() Dim strSuche As String Dim i As Long Dim x As Long Dim lastRowB As Long Dim lastRowD As Long lastRowB = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row lastRowD = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For i = 3 To lastRowB strSuche = Range("B" & i).Value Range("F" & Cells(Rows.Count, "F").End(xlUp).Row + 1) = strSuche For x = 3 To lastRowD If Range("D" & x) = strSuche Then Range("F" & Cells(Rows.Count, "F").End(xlUp).Row).ClearContents Exit For End If Next x Next i Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

309 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2 Tabellen auf Werte vergleichen

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

309 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread