Question

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

这是我到目前为止提出的代码，但它不起作用，并返回运行时错误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

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

Answer 1

您在利用FoundCell之前未设置Set FoundCell = SHT2.Cells(X, "C")，因此您应该在If SHT2.Cells(X, "C") = FindNo Then之后添加一些X。但是，由于您已经知道匹配的单元格行和列索引分别为3和With-End With，因此浪费了交叉引用。

此外，您可能希望采用workbook语法来引用对象（worksheet，range和. ...）并通过以下方式访问其方法或属性简单点（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）的意思。这将使您更好地控制正确的对象引用，并使您免于声明和使用的许多变量。

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

对于上述所有内容，您可以考虑以下重构

{{1}}

Answer 2

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

尝试用此替换该循环：

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

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

2 个答案: