Question

我需要帮助修改与不同工作簿中两个工作表之间的部件号（C列）匹配的宏。然后它粘贴来自＆＃39; Original＆＃39;的信息。 P9：X6500范围内的纸张进入＆＃39; New＆＃39;表格进入P9：X6500范围。第一张表＆＃39; Original＆＃39;在列C范围C9：C6500是匹配的部件号列。新的＆＃39; sheet具有与要匹配的部件号相同的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这样的名称，并使用更具描述性的名称。错误处理基本上只处理Sheets不存在，我认为可以更好地处理该场景。最后，您需要重新打开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希望在两个列中的表单之间进行匹配，并将相关的行信息粘贴到（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")

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

1 个答案: