VBA Macro

 avatar
cmad12
plain_text
2 months ago
4.0 kB
4
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 Sub
Editor is loading...
Leave a Comment