宏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或這樣的名稱並使用更具描述性的內容。錯誤處理基本上只處理Sheets不存在，我認爲可以更好地處理這種情況。最後，您需要重新打開ScreenUpdating以查看更改。

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 'Please reconsider this name 
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) 
     '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 

UPDATE：作爲OP希望在兩者上的列C片之間，以匹配並粘貼下面貼

2版跨越（山口p來山口X）第二代碼版本相關聯的行的信息：

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 'Please reconsider this name 
Dim i As Long, ii As Long 

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") 
    'Section that compares each cell value in lookup sheet "Original" col C and sees if there is a match in any of the rows in col C in "ThisSheet". Will be slow over larger numbers of rows. 

    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 ' so you can see the changes 

End Sub 

您可能需要修改幾行以適合您的環境，例如將其更改爲符合您的工作表名稱（粘貼到）。

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