VBA从另一个工作簿复制相应的值？
我有两个工作簿：
规划人员
Column K Column AG 123 £100 246 £20 555 £80 主
Column D Column R 123 £100 246 £20 555 £80
我试图将Planner，Column AG中的值复制到列D（主）中的项目编号与列K（Planner）相匹配的列R（主）中。
我的下面的代码没有产生任何错误，也没有产生任何结果 – 尽pipe他们是几场比赛。
请有人告诉我我要去哪里错了吗？
为了避免疑惑，我的工作手册肯定是开放的，所以find的文件。
代码 ：
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
而不是有2个For循环，只需使用Application.Match查找2个工作簿中的值之间的匹配。
使用下面的代码部分来replace你的：
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
你可以重构你的代码，如下所示：
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