将第一个工作簿中的值与第二个工作簿中的列匹配，并复制特定的单元格

我必须将第一个工作簿中的值匹配到第二个工作簿中的一列数据，然后将第一个工作簿中的特定单元格粘贴到第二个工作簿中的特定单元格（与匹配数据相同的行）中。

这里是我到目前为止的代码，但它不起作用，并返回运行时错误1004：应用程序定义或对象定义的错误。

Dim FindNo As String Dim X As Long, LastRow As Long Dim FoundCell As Range Dim FColumn As Integer, FRow As Integer Dim WB1 As Workbook, SHT1 As Worksheet Dim WB2 As Workbook, SHT2 As Worksheet Application.ScreenUpdating = False Set WB1 = ThisWorkbook Set WB2 = Workbooks.Open("Z:\ISO MTSO DOCUMENTS (New Templates)\Incident & Accident Monitoring (2016 and 2017)\Incident Monitoring 2016 and 2017.xlsx") Set SHT1 = WB1.Sheets("F-IMS-11") Set SHT2 = WB2.Sheets("2017") FindNo = SHT1.Range("Q1").Value LastRow = SHT2.Range("C" & Rows.Count).End(xlUp).Row For X = 3 To LastRow If SHT2.Cells(X, "C") = FindNo Then FRow = FoundCell.Row FColumn = FoundCell.Column SHT2.Range(Cells(FColumn + 14, FRow)) = SHT1.Cells(13, 1) SHT2.Range(Cells(FColumn + 15, FRow)) = SHT1.Cells(7, 6) SHT2.Range(Cells(FColumn + 17, FRow)) = SHT1.Cells(46, 2) SHT2.Range(Cells(FColumn + 18, FRow)) = SHT1.Cells(58, 2) SHT2.Range(Cells(FColumn + 19, FRow)) = SHT1.Cells(58, 13) End If Application.CutCopyMode = False Next X SHT2.Columns(17).WrapText = True SHT2.Columns(20).WrapText = True SHT2.Columns(21).WrapText = True WB2.Save WB2.Close Application.ScreenUpdating = True 

我很高兴听到有人提出build议，因为我在VBA中确实没有很好的背景，而我只是试图修改大部分代码。

Answer 1

在使用它之前，你并没有设置FoundCell ，所以你应该在If SHT2.Cells(X, "C") = FindNo Then之后添加一些Set FoundCell = SHT2.Cells(X, "C") 。 但是，由于您已经知道匹配的单元格行和列索引分别是X和3 ，因此这会浪费交叉引用。

此外，您可能希望采用With-End With语法来引用对象（ workbook ， worksheet range …）并通过简单的点（ . ）访问其方法或属性。 这将使您更好地控制适当的对象引用，并使您免于许多声明和使用的variables。

最后你应该避免在这些对象没有改变的时候，重复访问循环中的同一个对象

对于所有以上你可以考虑以下的重构

 Option Explicit Sub main() Dim FindNo As String Dim X As Long Dim val1 As Variant, val2 As Variant, val3 As Variant, val4 As Variant, val5 As Variant Application.ScreenUpdating = False With ThisWorkbook.Sheets("F-IMS-11") '<--| reference Worksheet object directly from "WB1" workbook FindNo = .Range("Q1").Value val1 = .cells(13, 1) val2 = .cells(7, 6) val3 = .cells(46, 2) val4 = .cells(58, 2) val5 = .cells(58, 13) End With With Workbooks.Open("Z:\ISO MTSO DOCUMENTS (New Templates)\Incident & Accident Monitoring (2016 and 2017)\Incident Monitoring 2016 and 2017.xlsx") '<--| open and reference wanted "WB2" workbook With .Sheets("2017") '<--| reference its "2017" worksheet For X = 3 To .Range("C" & .Rows.Count).End(xlUp).Row '<--| loop through its column "C" cells from row 3 down to last not empty one If .cells(X, "C") = FindNo Then .cells(X, 17) = val1 .cells(X, 18) = val2 .cells(X, 20) = val3 .cells(X, 21) = val4 .cells(X, 22) = val5 End If Next X Range("Q:Q , T:T, U:U").WrapText = True End With .Close True End With Application.ScreenUpdating = True End Sub 

Answer 2

在您的X = 3 to LastRow循环中，您使用FoundRow范围对象填充variables， 但FoundRow尚未设置。

尝试用这个replace那个循环：

 For X = 3 To LastRow If SHT2.Cells(X, "C") = FindNo Then Set FoundCell = SHT2.Cells(X, "C") FRow = FoundCell.Row FColumn = FoundCell.Column Set FoundCell = Nothing SHT2.Range(Cells(FColumn + 14, FRow)) = SHT1.Cells(13, 1) SHT2.Range(Cells(FColumn + 15, FRow)) = SHT1.Cells(7, 6) SHT2.Range(Cells(FColumn + 17, FRow)) = SHT1.Cells(46, 2) SHT2.Range(Cells(FColumn + 18, FRow)) = SHT1.Cells(58, 2) SHT2.Range(Cells(FColumn + 19, FRow)) = SHT1.Cells(58, 13) End If Application.CutCopyMode = False Next X