With following to this question Link
, I need to match the values found in wb1.coumns(1) with the other workbook wb2.coumns(1) with some particular conditions.
Wb2 will be filtered with the value Close at column 13 M.
My question: is to seek the Wb2 (the open workbook) Latest closing Date on column 11 K and then copy the respective values at columns (“B, and “Q:X”) (on the same row ),
Then paste these values in Wb1.columns (“S:AA”) respectively.
The below code designed to returns back with the respective values of only one column of wb2 (column “B”)
This is the Link for test workbooks.
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
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) 'Main Range
Set rng2 = ws2.Range("A3:X" & ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row) 'Opened Workbook_Range
arr1 = rng1.Value2
arr2 = rng2.Value2
'place the unique last key in a dictionary:
Dim i As Long
For i = 1 To UBound(arr2)
If arr2(i, 13) = "Close" Then 'Column (Status)
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, 19) = dict(arr1(i, 1))(0) 'extract first item array element
Else
arr1(i, 19) = "NA"
End If
Next i
rng1.Value2 = arr1 'drop back the updated array content
ws1.Activate
' wb2.Close SaveChanges:=False
Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
CodePudding user response：
Please, test the next updated code:
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
'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) 'Main Range
Set rng2 = ws2.Range("A3:X" & ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row) 'Opened Workbook_Range
arr1 = rng1.Value2
arr2 = rng2.Value2
'place the unique last key in a dictionary:
Dim i As Long, arrAtt, j As Long, k As Long
ReDim arrAtt(7) 'the 1D array should contain maximum number of elements from "Q" to "X"
'meaning 8 columns. since arrAtt is 1D zero based, it may keep 8 elements
For i = 1 To UBound(arr2)
If arr2(i, 13) = "Close" Then 'Column (Status)
Erase arrAtt: ReDim arrAtt(7) 'erase the previous loaded array, if the case (to be loaded...)
If Not dict.Exists(arr2(i, 1)) Then
For j = 0 To UBound(arrAtt) 'iterate between the 8 array elements
If arr2(i, 17 j) <> "" Then
arrAtt(k) = arr2(i, 17 k): k = k 1 'add the found URLs and increment k
Else
Exit For 'exit the iteration if no URL exists
End If
Next j
If k > 0 Then ReDim Preserve arrAtt(k - 1) 'keep only the loaded elements
dict(arr2(i, 1)) = Array(arr2(i, 2), arr2(i, 11), arrAtt) 'Place attachments array, too
k = 0 'reinitialize k variable
Else
If CDate(arr2(i, 11)) > CDate(dict(arr2(i, 1))(1)) Then 'Change the item only in case of a more recent Date
Erase arrAtt: ReDim arrAtt(7) 'erase the previous loaded array
For j = 0 To UBound(arrAtt)
If arr2(i, 17 j) <> "" Then
arrAtt(k) = arr2(i, 17 k): k = k 1
Else
Exit For
End If
Next j
If k > 0 Then ReDim Preserve arrAtt(k - 1)
dict(arr2(i, 1)) = Array(arr2(i, 2), arr2(i, 11), arrAtt) 'Place attachments array, too
k = 0
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, 19) = dict(arr1(i, 1))(0) 'extract first item array element
For j = 0 To UBound(dict(arr1(i, 1))(2)) 'extract existing URLs
If dict(arr1(i, 1))(2)(j) = "" Then Exit For 'exit the loop in case of empty strings
arr1(i, 20 j) = dict(arr1(i, 1))(2)(j) 'place the URLs in their position
Next j
Else
arr1(i, 19) = "NA"
End If
Next i
rng1.Value2 = arr1 'drop back the updated array content
ws1.Activate
' wb2.Close SaveChanges:=False
Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
But, if you intend to adapt wb2 workbook in terms of clearing some URLs (for the latest closing Date) , the code should be adapted to preliminarily clear the range "S:AA" in wb1 till the end of the sheet. Otherwise, existing URLs may remain from the previous run