excel - 获取最近截止日期的相应值

Question

如上图所示:
我需要在某些条件下将 Wb1.coumns(1) 上的值与其他工作簿 Wb2.coumns(1) 进行匹配。
Wb2 将过滤 M 列中的值 Close。
然后，我查找最新的截止日期并在 B 列中获取其各自的值，并将该值输入到 Wb1.column(K) 中。
下面的代码可以正确地处理所提供的示例，但它在我的实际数据集上并不可靠，因为它取决于许多列从最旧到最新的排序。
这是link for the provided sample

  Sub Get_the_respective_value_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
     
       Application.ScreenUpdating = False
     
       Set wb1 = ThisWorkbook
       Set wb2 = Workbooks.Open("Path of wb2", UpdateLinks:=False, ReadOnly:=True)
     
        Set ws1 = wb1.Sheets(1)
        Set ws2 = wb2.Sheets(1)
     
         Set rng1 = ws1.Range("A3:K" & ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row)   'Main Range
         Set rng2 = ws2.Range("A3:M" & ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row)
     
          arr1 = rng1.Value2
          arr2 = rng2.Value2
     
       Dim i As Long, k As Long
        For i = LBound(arr1) To UBound(arr1)
         For k = LBound(arr2) To UBound(arr2)
     
          If arr1(i, 1) = arr2(k, 1) And arr2(k, 13) = "Close" Then
             rng1.Cells(i, 11) = arr2(k, 2)
          End If
     
          Next k
        Next i
     
       wb2.Close SaveChanges:=False
       Application.ScreenUpdating = True
    End Sub

Answer 1

请尝试下一个改编的代码。它使用字典来保留打开的工作簿的唯一 kay(以及“K:K”中的最后一个值作为项目)，然后将适当的数据放入工作工作簿中:

Sub Get_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 Object
   
   Application.ScreenUpdating = False

   Set wb1 = ThisWorkbook
   'Please, update the real path of "Book2.xlsx":
   Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\Book2.xlsx", UpdateLinks:=False, ReadOnly:=True)
   
    Set ws1 = wb1.Sheets(1)
    Set ws2 = wb2.Sheets(1)
   
     Set rng1 = ws1.Range("A3:K" & ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row)   'Main Range
     Set rng2 = ws2.Range("A3:M" & ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row)

      arr1 = rng1.Value2
      arr2 = rng2.Value2

     'place the unique last key in a dictionary:
     Dim i As Long
     Set dict = CreateObject("Scripting.dictionary")
     For i = 1 To UBound(arr2)
        If arr2(i, 13) = "Close" Then
             dict(arr2(i, 1)) = arr2(i, 2)
        End If
    Next i
    Debug.Print Join(dict.items, "|") 'just to visualy see the result
    
    'Place the necessary data in its place:
    For i = 1 To UBound(arr1)
        If dict.Exists(arr1(i, 1)) Then
            arr1(i, 11) = dict(arr1(i, 1))
        Else
            arr1(i, 11) = "NA"
        End If
    Next i
    
    rng1.Value2 = arr1 'drop back the updated array content
    
   wb2.Close SaveChanges:=False
   
   Application.ScreenUpdating = True
   MsgBox "Ready..."
End Sub

要打开的工作簿的“K:K”列必须按升序排序...

已编辑:

下一个版本无需对“K:K”列进行排序即可工作:

Sub Get_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 Object
   
   Application.ScreenUpdating = False

   Set wb1 = ThisWorkbook
   Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\Book2.xlsx", UpdateLinks:=False, ReadOnly:=True)
   
    Set ws1 = wb1.Sheets(1)
    Set ws2 = wb2.Sheets(1)
   
     Set rng1 = ws1.Range("A3:K" & ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row)   'Main Range
     Set rng2 = ws2.Range("A3:M" & ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row)

      arr1 = rng1.Value2
      arr2 = rng2.Value2

     'place the unique last key in a dictionary:
     Dim i As Long
     Set dict = CreateObject("Scripting.dictionary")
     For i = 1 To UBound(arr2)
        If arr2(i, 13) = "Close" Then
            If Not dict.Exists(arr2(i, 1)) Then
                dict(arr2(i, 1)) = Array(arr2(i, 2), arr2(i, 11)) 'place the date from K:K, too
            Else
                If CDate(arr2(i, 11)) > CDate(dict(arr2(i, 1))(1)) Then 'change the item only in case of a more recent date:
                    dict(arr2(i, 1)) = Array(arr2(i, 2), arr2(i, 11))
                End If
            End If
        End If
    Next i

    'Place the necessary data in its place:
    For i = 1 To UBound(arr1)
        If dict.Exists(arr1(i, 1)) Then
            arr1(i, 11) = dict(arr1(i, 1))(0) 'extract first item array element
        Else
            arr1(i, 11) = "NA"
        End If
    Next i
    
    rng1.Value2 = arr1 'drop back the updated array content
    
   wb2.Close SaveChanges:=False
   
   Application.ScreenUpdating = True
   MsgBox "Ready..."
End Sub