宏 VBA：匹配两个工作簿中的文本单元格并粘贴

Question

我需要帮助修改与不同工作簿中两张工作表之间的部件号（C 列）匹配的宏。然后它将“原始”工作表中 P9:X6500 范围内的信息粘贴到“新”工作表中 P9:X6500 范围内。 C 列范围 C9:C6500 中的第一张表“原始”是匹配的部件号列。 “新”表具有与要匹配的部件号相同的 C 列。我只想匹配并粘贴可见值。

我最初有这个宏代码，它只将可见值从一个工作簿复制粘贴到另一个工作簿，我想修改它以匹配并复制粘贴：

Sub GetDataDemo()
Const FileName As String = "Original.xlsx"
Const SheetName As String = "Original"
FilePath = "C:\Users\me\Desktop\"
Dim wb As Workbook
Dim this As Worksheet
Dim i As Long, ii As Long

Application.ScreenUpdating = False

If IsEmpty(Dir(FilePath & FileName)) Then

    MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist"
Else

    Set this = ActiveSheet

    Set wb = Workbooks.Open(FilePath & FileName)

With wb.Worksheets(SheetName).Range("P9:X500")
On Error Resume Next
.SpecialCells(xlCellTypeVisible).Copy this.Range("P9")
On Error GoTo 0
End With

End If


ThisWorkbook.Worksheets("NEW").Activate

End Sub

这也是我想要的样子：

Original

NEW

感谢您的帮助！

Answer 1

尝试以下操作，它将范围从一张纸复制到另一张纸。您可以将With wb.Worksheets(SheetName).Range("P9:X500") 分解为With wb.Worksheets(SheetName)，然后在With 语句中使用.Range("P9:X500").Copy this.Range("P9")。避免使用 i 或 ii 或 this 之类的名称，并使用更具描述性的名称。错误处理基本上只处理不存在的表格，我认为可以更好地处理这种情况。最后，您需要重新打开 ScreenUpdating 才能查看更改。

Option Explicit

Public Sub GetDataDemo()

    Const FILENAME As String = "Original.xlsx"
    Const SHEETNAME As String = "Original"
    Const FILEPATH As String = "C:\Users\me\Desktop\"
    Dim wb As Workbook
    Dim this As Worksheet                        'Please reconsider this name

    Application.ScreenUpdating = False

    If IsEmpty(Dir(FILEPATH & FILENAME)) Then
        MsgBox "The file " & FILENAME & " was not found", , "File Doesn't Exist"
    Else
        Set this = ActiveSheet
        Set wb = Workbooks.Open(FILEPATH & FILENAME)

        With wb.Worksheets(SHEETNAME)
            'On Error Resume Next ''Not required here unless either of sheets do not exist
            .Range("P9:X500").Copy this.Range("P9")
            ' On Error GoTo 0
        End With

    End If

    ThisWorkbook.Worksheets("NEW").Activate
    Application.ScreenUpdating = True            ' so you can see the changes

End Sub

更新：由于 OP 希望在两者中的 C 列上的工作表之间进行匹配，并将关联的行信息粘贴到下面发布的第二个代码版本（Col P 到 Col X）

版本 2：

Option Explicit

Public Sub GetDataDemo()

    Dim wb As Workbook
    Dim lookupRange As Range
    Dim matchRange As Range

    Set wb = ThisWorkbook
    Set lookupRange = wb.Worksheets("Original").Range("C9:C500")
    Set matchRange = wb.Worksheets("ThisSheet").Range("C9:C500")

    Dim lookupCell As Range
    Dim matchCell As Range

    With wb.Worksheets("Original")

        For Each lookupCell In lookupRange

            For Each matchCell In matchRange
                If Not IsEmpty(matchCell) And matchCell = lookupCell Then 'assumes no gaps in lookup range
                    matchCell.Offset(0, 13).Resize(1, 9).Value2 = lookupCell.Offset(0, 13).Resize(1, 9).Value2
                End If

            Next matchCell

        Next lookupCell

    End With

    ThisWorkbook.Worksheets("NEW").Activate
    Application.ScreenUpdating = True

End Sub

您可能需要修改几行以适应您的环境，例如更改此名称以符合您的工作表名称（粘贴到）。

Set matchRange = wb.Worksheets("ThisSheet").Range("C9:C500")