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

我需要帮助修改一个宏，该宏与不同工作簿中两张图纸之间的零件号列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

我也希望它看起来像这样：

---

我感谢你的帮助

尝试以下操作，将范围从一张图纸复制到另一张图纸。您可以将wb.WorksheetsSheetName.RangeP9:X500分解为With wb.WorksheetsSheetName，然后使用.RangeP9:X500.Copy this.RangeP9在With语句中。避免使用像i或ii或这个这样的名称，并使用更具描述性的名称。错误处理本质上只是处理不存在的工作表，我认为可以更好地处理这种情况。最后，您需要重新打开屏幕更新以查看更改

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列上的表之间进行匹配，并将相关行信息粘贴到下面发布的第二个代码版本的p列到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")

---

您只是从一个范围复制到另一个工作表中的匹配范围吗？如果是这样，类似于：b.worksheetsheetsname.RangeP9:X500.Copy this.RangeP9是的，但我想添加一个匹配项，如果这样的话？函数，该函数也会忽略隐藏值。直接复制和粘贴VBA操作不会复制隐藏行。感谢这一点，我对VBA还是新手。如何在代码中添加匹配函数？这是我遇到的主要问题，匹配两列并粘贴相关信息。