比较两个工作簿并删除匹配的行

Question

我正在尝试比较两个工作簿，但在运行宏时不太可能出现错误

“下标超出范围”。

任何人都可以帮助消除错误吗？谢谢

Sub CompInTwoWorkbooks()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim c As Range, rng As Range
    Dim lnLastRow1 As Long, lnLastRow2 As Long
    Dim lnTopRow1 As Long, lnTopRow2 As Long
    Dim lnCols As Long, i As Long

    Set wb1 = Workbooks("listeappli.xlsx") 'Adjust as required
    Set wb2 = Workbooks("Keyword.xlsx") 'Adjust as required

    Set ws1 = wb1.Sheets("listeappli") 'Adjust as required
    Set ws2 = wb2.Sheets("Keyword") 'Adjust as required

    lnTopRow1 = 2 'first row containing data in wb1 'Adjust as required
    lnTopRow2 = 2 'first row containing data in wb2 'Adjust as required

     'Find last cells containing data:
    lnLastRow1 = ws1.Range("M:M").Find("*", Range("M1"), LookIn:=xlValues, searchdirection:=xlPrevious).Row
    lnLastRow2 = ws2.Range("A:A").Find("*", Range("A1"), LookIn:=xlValues, searchdirection:=xlPrevious).Row

    Set rng = ws2.Range("A" & lnTopRow2 & ":A" & lnLastRow2)

    lnCols = ws1.Columns.Count
    ws1.Columns(lnCols).Clear 'Using the very right-hand column of the sheet

    For i = lnLastRow1 To lnTopRow1 Step -1
        For Each c In rng
            If ws1.Range("M" & i).Value = c.Value Then
                ws1.Cells(i, lnCols).Value = "KEEP" 'Add tag to right-hand column of sheet if match found
                Exit For
            End If
        Next c
    Next i

     'Delete rows where the right-hand column of the sheet is blank
    Set rng = ws1.Range(Cells(lnTopRow1, lnCols), Cells(lnLastRow1, lnCols))
    rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    ws1.Columns(lnCols).Clear
End Sub

Answer 1

如果您的工作簿尚未打开并且您希望宏自动打开它，您必须使用Workbooks.Open Method。

如果listeappli.xlsx 与实际文件在同一路径中，则使用以下内容

Set wb1 = Workbooks.Open(Filename:=ThisWorkbook.Path & Application.PathSeparator & "listeappli.xlsx")

或指定Filename:=like的完整路径

Set wb1 = Workbooks.Open(Filename:="C:\MyFolder\listeappli.xlsx")