比較不同工作簿中的兩列

比較不同工作簿中的兩列

如果我能在嘗試建立 vba 巨集的問題上獲得一些幫助,我將不勝感激。我有兩個工作簿,我想將工作簿1 中的“N”列與工作簿2 中的“F”列進行比較。沒有找到匹配項,我想複製列後的下一個單元格工作簿2 中的“F”。開頭,因此我創建了下面的程式碼,透過使用部分名稱來選擇它。

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

即使我能指出正確的方向,那就太棒了。

答案1

這個解釋不是很清楚

...如果有匹配項,則向下移動到下一個單元格,如果沒有找到匹配項,我想複製工作簿 2 中“F”列之後的下一個單元格...

但嘗試這樣的事情,並相應地修改它


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

另外,您指的是 2 個工作簿(文件),
但您的代碼指的是工作表(同一工作簿中的選項卡)

相關內容