vba複製另一個工作簿中的相應值？

Question

我有兩個工作簿：

規劃

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

主

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

我想要的值從計劃複製，欄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