按条件从另一工作簿复制数据：获取最新关闭日期对应值

需求说明 #

• 匹配两个工作簿（wb1、wb2）的第1列（A列）
• 仅处理wb2中第13列（M列）值为Close的行
• 在符合条件的行中，筛选出第11列（K列）关闭日期最新的记录
• 将该行的B列、Q:X列数据，复制到wb1对应行的S:AA列

现有代码仅能返回B列数据，以下是修改后的完整实现：

Option Explicit
Option Compare Text
 
Sub Get_Respective_Values_Of_Last_Closing_Date()
 
   Dim wb1 As Workbook, wb2 As Workbook
   Dim ws1 As Worksheet, ws2 As Worksheet
   Dim rng1 As Range, rng2 As Range
   Dim arr1() As Variant, arr2() As Variant
   Dim dict As New Dictionary
   Dim i As Long, colIdx As Long
 
   Application.ScreenUpdating = False
 
   Set wb1 = ThisWorkbook
   Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\Book_B.xlsb", UpdateLinks:=False, ReadOnly:=True)
 
   Set ws1 = wb1.Sheets(1)
   Set ws2 = wb2.Sheets(1)
 
   Set rng1 = ws1.Range("A3:AA" & ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row)
   Set rng2 = ws2.Range("A3:X" & ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row)
 
   arr1 = rng1.Value2
   arr2 = rng2.Value2
 
   ' 用字典存储每个匹配键对应的最新关闭日期及所需数据
   For i = 1 To UBound(arr2)
      If arr2(i, 13) = "Close" Then
         ' 准备存储数组：索引0=关闭日期，1=B列，2-9=Q到X列数据
         Dim dataArr() As Variant
         ReDim dataArr(0 To 9)
         dataArr(0) = arr2(i, 11)
         dataArr(1) = arr2(i, 2)
         For colIdx = 17 To 24 ' Q列为17，X列为24
            dataArr(colIdx - 15) = arr2(i, colIdx)
         Next colIdx
 
         If Not dict.Exists(arr2(i, 1)) Then
            dict(arr2(i, 1)) = dataArr
         Else
            ' 比较日期，保留最新记录
            If CDate(arr2(i, 11)) > CDate(dict(arr2(i, 1))(0)) Then
               dict(arr2(i, 1)) = dataArr
            End If
         End If
      End If
   Next i
 
   ' 将数据批量写入wb1对应列
   For i = 1 To UBound(arr1)
      If dict.Exists(arr1(i, 1)) Then
         Dim targetArr() As Variant
         targetArr = dict(arr1(i, 1))
         ' S列（索引19）对应targetArr(1)，AA列（索引27）对应targetArr(9)
         For colIdx = 19 To 27
            arr1(i, colIdx) = targetArr(colIdx - 18)
         Next colIdx
      Else
         ' 无匹配时填充NA到目标列范围
         For colIdx = 19 To 27
            arr1(i, colIdx) = "NA"
         Next colIdx
      End If
   Next i
 
   rng1.Value2 = arr1
 
   ws1.Activate
   wb2.Close SaveChanges:=False
 
   Application.ScreenUpdating = True
   MsgBox "处理完成..."
 
End Sub

关键改动说明 #

1. 扩展字典存储：新增dataArr数组，一次性存储关闭日期、B列及Q到X列的所有数据，确保后续可批量提取
2. 保留日期筛选逻辑：维持通过日期比较保留最新记录的逻辑，保证数据准确性
3. 批量写入优化：遍历wb1数组时，将目标数据一次性写入S到AA列，提升处理效率
4. 统一无匹配处理：对未匹配到的行，统一在目标列填充NA

内容的提问来源于stack exchange，提问作者Waleed