VBA从另一个工作簿复制相应的值？

Question

我有两本工作簿：

策划人

Column K        Column AG
123             £100
246             £20
555             £80

主

Column D       Column R
123            £100
246            £20
555            £80

我正在尝试将Planner的AG列中的值复制到R列（主）中，其中D列（主）中的物料编号与K列（Planner）相匹配。

我的下面的代码没有产生错误，也没有产生任何结果-尽管它们是多次匹配。

请有人能告诉我我要去哪里错吗？

为避免疑问，我的工作簿肯定可以打开，因此可以找到该文件。

代码 ：

Sub PlannerOpen()

'Set Variables
Dim wb2 As Workbook
Dim i As Long
Dim j As Long
Dim lastRow As Long
Dim app As New Excel.Application    

'Find Planner
If Len(FindDepotMemo) Then        
    'If Found Then Set Planner Reference.
    app.Visible = False 'Visible is False by default, so this isn't necessary
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Set wb2 = Workbooks.Open(FindDepotMemo, ReadOnly:=True, UpdateLinks:=False)

    'If We have our planner lets continue...

    'With my workbook
    With wb2.Worksheets(1)
        lastRow = .Cells(.Rows.Count, "K").End(xlUp).Row

        'Lets begin our data merge
        j = 2
        For i = 2 To lastRow
            'If data meets criteria
            'Check Planner For Turnover
            If ThisWorkbook.Worksheets("Data").Range("D" & j).Value = .Range("K" & i).Value Then ' check if Item number matches
                ThisWorkbook.Worksheets("Data").Range("R" & j).Value = .Range("AG" & i).Value

                j = j + 1
            End If
            'Continue until all results found
        Next i
    End With

    'All Done, Let's tidy up
    'Close Workbooks
    'wb2.Close SaveChanges:=False
    'app.Quit
    'Set app = Nothing

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End If

End Sub

Function FindDepotMemo() As String

    Dim Path As String
    Dim FindFirstFile As String

    Path = "G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\" & "8." & " " & Year(Date) & "\"
    FindFirstFile = Dir$(Path & "*.xlsx")
    While (FindFirstFile <> "")
        If InStr(FindFirstFile, "Planner") > 0 Then
            FindDepotMemo = Path & FindFirstFile
            Exit Function
        End If
        FindFirstFile = Dir
    Wend

End Function

Answer 1

而不是使用2个For循环，只需使用Application.Match在2个工作簿中的值之间查找匹配项。

使用下面的这段代码替换您的代码：

    With wb2.Worksheets(1)
        Dim MatchRow As Variant '<-- define variable to get the row number if Match is successful

        lastRow = .Cells(.Rows.Count, "K").End(xlUp).Row

        'Lets begin our data merge
        For i = 2 To lastRow
            ' If data meets criteria
            ' Check Planner For Turnover
            ' Use Application.Match to find matching results between workbooks
            If Not IsError(Application.Match(ThisWorkbook.Worksheets("Data").Range("D" & i).Value, .Range("K2:K" & lastorw), 0)) Then ' check if Match is successful
                MatchRow = Application.Match(ThisWorkbook.Worksheets("Data").Range("D" & i).Value, .Range("K2:K" & lastorw), 0) ' <-- get the row number where the match was found
                ThisWorkbook.Worksheets("Data").Range("R" & j).Value = .Range("AG" & MatchRow).Value
            End If
            'Continue until all results found
        Next i
    End With

Answer 2

您可以按以下方式重构代码：

Option Explicit

Sub PlannerOpen()
    Dim dataRng As Range, cell As Range
    Dim depotMemo As String
    Dim iRow As Variant

    If FindDepotMemo(depotMemo) Then '<--| if successfully found the wanted file        
        With ThisWorkbook.Worksheets("Data1") '<--| reference your "Master" workbook relevant worksheet
            Set dataRng = .Range("D2", .Cells(.Rows.Count, "D").End(xlUp)) '<--| set its item numbers range
        End With

        With Workbooks.Open(depotMemo, ReadOnly:=True, UpdateLinks:=False).Worksheets(1) '<--| open depotMemo workbook and reference its first worksheet
            For Each cell In .Range("K2", .Cells(.Rows.Count, "K").End(xlUp)) '<--| loop through referenced worksheet column "K" cells from row 2 down to last not empty one
                iRow = Application.Match(cell.Value, dataRng, 0) '<--| try finding current depotMemo item number in Master item numbers range
                If Not IsError(iRow) Then dataRng(iRow, 1).Offset(, 14).Value = cell.Offset(, 22) '<--| if found then grab depotMemo current item amount and place it in corresponding "master" data sheet column R
            Next
            .Parent.Close False
        End With
    End If    
End Sub

Function FindDepotMemo(depotMemo As String) As Boolean    
    Dim Path As String
    Dim FindFirstFile As String

    Path = "G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\" & "8." & " " & Year(Date) & "\"
    FindFirstFile = Dir$(Path & "*.xlsx")
    While (FindFirstFile <> "")
        If InStr(FindFirstFile, "Planner") > 0 Then
            FindDepotMemo = True
            depotMemo = Path & FindFirstFile
            Exit Function
        End If
        FindFirstFile = Dir
    Wend    
End Function