☰

Vergleichen Sie zwei Spalten in unterschiedlichen Arbeitsmappen

tag-icon • tag-icon microsoft-excel microsoft-excel-2010 vba
Vergleichen Sie zwei Spalten in unterschiedlichen Arbeitsmappen

Ich wäre dankbar, wenn ich Hilfe bei einem Problem beim Erstellen eines VBA-Makros bekommen könnte. Ich habe zwei Arbeitsmappen und möchte die Spalte „N“ in Arbeitsmappe 1 mit der Spalte „F“ in Arbeitsmappe 2 vergleichen. Wenn dann eine Übereinstimmung gefunden wird, gehe ich zur nächsten Zelle darunter, wenn keine Übereinstimmungen gefunden wurden, möchte ich die nächste Zelle nach Spalte „F“ in Arbeitsmappe 2 kopieren. Arbeitsmappe 2 wird nicht denselben Namen haben, wenn ich sie jeden Morgen bekomme, aber der Name der Arbeitsmappe beginnt immer mit „Kopie von“, also habe ich den folgenden Code erstellt, um sie anhand eines Teilnamens auszuwählen.

For Each ws In ActiveWorkbook.Worksheets
    If ws.Name Like "Copy of*" Then
        ws.Select
        Exit For
    End If
Next ws

Selbst wenn ich in die richtige Richtung gelenkt werden könnte, wäre das großartig.

Antwort1

Diese Erklärung ist nicht ganz klar

...wenn eine Übereinstimmung vorliegt, zur nächsten Zelle nach unten wechseln; wenn keine Übereinstimmungen gefunden wurden, möchte ich die nächste Zelle nach der Spalte „F“ in Arbeitsmappe 2 kopieren...

aber versuchen Sie so etwas und ändern Sie es entsprechend

Option Explicit

Public Sub CompareWorkBooks()
    Dim ws1 As Worksheet, ws2 As Worksheet

    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = GetWSCopy("Copy of*")

    If Not ws2 Is Nothing Then

        Dim r As Long, cel As Range, found As Variant, ws2lr As Long

        optimizeXL True
        For r = ws1.UsedRange.Rows.Count To 1 Step -1
            Set cel = ws1.Cells(r, ws1.Columns("N").Column)
            If Len(cel.Value2) > 0 Then
                found = Application.Match(cel.Value2, ws2.UsedRange.Columns("F"), 0)

                If Not IsError(found) Then  'a match was found so move next cell down
                    cel.Offset(1).EntireRow.Insert xlDown
                Else    'match not found so copy row from ws1 to first empty row of ws2
                    ws2lr = ws2.UsedRange.Rows.Count + 1
                    ws1.UsedRange.Rows(cel.Row).EntireRow.Copy ws2.Cells(ws2lr, 1)
                End If
            End If
        Next
        optimizeXL False
    End If
End Sub

Private Function GetWSCopy(ByVal wsName As String) As Worksheet
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name Like wsName Then
            Set GetWSCopy = ws
            Exit Function
        End If
    Next
End Function

Public Sub optimizeXL(Optional ByVal settingsOff As Boolean = True)
    With Application
        .ScreenUpdating = Not settingsOff
        .Calculation = IIf(settingsOff, xlCalculationManual, xlCalculationAutomatic)
        .EnableEvents = Not settingsOff
    End With
End Sub

Außerdem beziehen Sie sich auf 2 Arbeitsmappen (Dateien),
aber Ihr Code bezieht sich auf Arbeitsblätter (Registerkarten innerhalb derselben Arbeitsmappe).

verwandte Informationen