VBA Macro
cmad12
plain_text
10 months ago
4.0 kB
6
Indexable
Sub VergleicheSpaltenInZweiDateien()
Dim BOM_2025-02-19_MASTER_v2 As String, BOM_2025-02-27_DiffBOM_1 As String
Dim spalte As String
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow1 As Long, lastRow2 As Long
Dim i As Long, j As Long
Dim gefunden As Boolean
Dim ergebnisWs As Worksheet
' Benutzer nach Dateipfaden und Spalte fragen
BOM_2025-02-19_MASTER_v2 = Application.GetOpenFilename("Excel-Dateien (*.xlsx), *.xlsx", , "Wähle die erste Excel-Datei")
If BOM_2025-02-19_MASTER_v2 = "False" Then Exit Sub
BOM_2025-02-27_DiffBOM_1 = Application.GetOpenFilename("Excel-Dateien (*.xlsx), *.xlsx", , "Wähle die zweite Excel-Datei")
If BOM_2025-02-27_DiffBOM_1 = "False" Then Exit Sub
spalte = InputBox("Gib den Spaltenbuchstaben ein (z.B. A, B, C...)", "Spaltenauswahl")
If spalte = "" Then Exit Sub
' Dateien öffnen
Set wb1 = Workbooks.Open(BOM_2025-02-19_MASTER_v2)
Set wb2 = Workbooks.Open(BOM_2025-02-27_DiffBOM_1)
' Erste Arbeitsblätter in beiden Dateien verwenden
Set ws1 = wb1.Worksheets(1)
Set ws2 = wb2.Worksheets(1)
' Letzte Zeile in beiden Spalten finden
lastRow1 = ws1.Cells(ws1.Rows.Count, spalte).End(xlUp).Row
lastRow2 = ws2.Cells(ws2.Rows.Count, spalte).End(xlUp).Row
' Neues Arbeitsblatt für Ergebnisse erstellen
Set ergebnisWs = ThisWorkbook.Worksheets.Add
ergebnisWs.Name = "Vergleichsergebnis"
' Überschriften erstellen
ergebnisWs.Range("A1").Value = "Wert"
ergebnisWs.Range("B1").Value = "Status"
ergebnisWs.Range("C1").Value = "Quelle"
' Formatierung der Überschriften
ergebnisWs.Range("A1:C1").Font.Bold = True
Dim ergebnisZeile As Long
ergebnisZeile = 2
' Werte aus Datei 1 prüfen
For i = 1 To lastRow1
gefunden = False
For j = 1 To lastRow2
If ws1.Range(spalte & i).Value = ws2.Range(spalte & j).Value Then
gefunden = True
Exit For
End If
Next j
' Wert in Ergebnisblatt eintragen
ergebnisWs.Range("A" & ergebnisZeile).Value = ws1.Range(spalte & i).Value
If Not gefunden Then
ergebnisWs.Range("B" & ergebnisZeile).Value = "Nur in Datei 1"
ergebnisWs.Range("B" & ergebnisZeile).Interior.Color = RGB(255, 200, 200) ' Hellrot
Else
ergebnisWs.Range("B" & ergebnisZeile).Value = "In beiden Dateien"
ergebnisWs.Range("B" & ergebnisZeile).Interior.Color = RGB(200, 255, 200) ' Hellgrün
End If
ergebnisWs.Range("C" & ergebnisZeile).Value = "Datei 1"
ergebnisZeile = ergebnisZeile + 1
Next i
' Werte aus Datei 2 prüfen, die nicht in Datei 1 sind
For j = 1 To lastRow2
gefunden = False
For i = 1 To lastRow1
If ws2.Range(spalte & j).Value = ws1.Range(spalte & i).Value Then
gefunden = True
Exit For
End If
Next i
If Not gefunden Then
' Wert in Ergebnisblatt eintragen
ergebnisWs.Range("A" & ergebnisZeile).Value = ws2.Range(spalte & j).Value
ergebnisWs.Range("B" & ergebnisZeile).Value = "Nur in Datei 2"
ergebnisWs.Range("B" & ergebnisZeile).Interior.Color = RGB(255, 255, 200) ' Hellgelb
ergebnisWs.Range("C" & ergebnisZeile).Value = "Datei 2"
ergebnisZeile = ergebnisZeile + 1
End If
Next j
' Spaltenbreite anpassen
ergebnisWs.Columns("A:C").AutoFit
' Dateien schließen
wb1.Close SaveChanges:=False
wb2.Close SaveChanges:=False
MsgBox "Vergleich abgeschlossen. Ergebnisse sind im Arbeitsblatt 'Vergleichsergebnis' zu finden.", vbInformation
End SubEditor is loading...
Leave a Comment