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

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

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

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 

这也是我想要的样子：

原版的

新

我感谢帮助！

Answer 1

请尝试以下步骤，将范围从一个纸张复制到另一个纸张。 你可以将With wb.Worksheets(SheetName).Range("P9:X500")分成With wb.Worksheets(SheetName)然后使用.Range("P9:X500").Copy this.Range("P9")里面With语句。 避免使用像i或ii这样的名字，并使用更具描述性的名称。 error handling基本上只处理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 

更新：因为任择议定书希望匹配列C在两个工作表之间，并粘贴相关的行信息（Col P到列表X）第二个代码版本下面张贴

版本2：

 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")