Copy the respective values from another workbook depend on specific conditions

0 votes

I need to match the data from the workbook wb1.coumns(1) with the other workbook wb2.coumns(1) under specific circumstances as described in this inquiry Link.
The value Close will be filtered out of Wb2 at column 13 M.
To find the most recent closing date for the open worksheet Wb2, locate column 11 K, copy the corresponding values from columns B and Q:X (on the same row), and then paste these values into the corresponding Wb1 columns S:AA.
The code below is intended to return the values from just one column of wb2 (column "B")

This is the Link for the 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
Feb 6, 2023 in Others by Kithuzzz
• 38,010 points
354 views

1 answer to this question.

0 votes

Try this:

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
answered Feb 6, 2023 by narikkadan
• 63,420 points

Related Questions In Others

0 votes
1 answer
0 votes
1 answer
0 votes
1 answer

Excel formula for searching two text in one cell and return values based on the result

You can include a second IF within ...READ MORE

answered Oct 10, 2022 in Others by narikkadan
• 63,420 points
981 views
0 votes
1 answer

How can I copy from specific sheet in excel

You should use wb.Sheets("Name of sheet").Copy - ...READ MORE

answered Oct 29, 2022 in Others by narikkadan
• 63,420 points
307 views
0 votes
1 answer

VBA How do I replace the range with an array in SUMIF

You can't, in my opinion. When you ...READ MORE

answered Feb 7, 2023 in Others by narikkadan
• 63,420 points
511 views
0 votes
1 answer

Excel VBA compare values on multiple rows and execute additional code

I would use a Dictionary & Collection ...READ MORE

answered Feb 7, 2023 in Others by narikkadan
• 63,420 points
1,370 views
0 votes
1 answer

How to concatenate elements of a single-dimensional array using VBA?

Using Microsoft 365's UNIQUE and SORT in VBA ' This is a ...READ MORE

answered Feb 16, 2023 in Others by narikkadan
• 63,420 points
365 views
0 votes
1 answer

Loops through Check Box in VBA

Please attempt the next option. Assuming you ...READ MORE

answered Apr 1, 2023 in Others by narikkadan
• 63,420 points
567 views
0 votes
1 answer
0 votes
1 answer

How to expend the code to transfer data from one spreadsheet to another based on multiple criteria

 The progress bar is unnecessary. Option Explicit Sub VTest2() ...READ MORE

answered Jan 29, 2023 in Others by narikkadan
• 63,420 points
248 views
webinar REGISTER FOR FREE WEBINAR X
REGISTER NOW
webinar_success Thank you for registering Join Edureka Meetup community for 100+ Free Webinars each month JOIN MEETUP GROUP