Look for ID in another sheet and copy and paste cell value - in a loop

[sazza]

Hi Guys,

I have a script where i'm trying to :

(1) lookup column 2 in the "Acct Awaiting 2 week review" worksheet against column 2 in the "MIV Case Details" worksheet and

(2) when it finds a match copy the details from column N in "Acct Awaiting 2 week review" into column N in the "MIV Case Details"

I have the following and according to my message box the data matches but nothing copies ?
Can you help me please ?

Private Sub CommandButton1_Click()

Dim i As Long
Dim j As Long
changing_data = Worksheets("Acct Awaiting 2 week review").Range("B" & Rows.count).End(xlUp).Row
to_be_changed_data = Worksheets("MIV Case Details").Range("B" & Rows.count).End(xlUp).Row

    For j = 1 To changing_data
        For i = 1 To to_be_changed_data
            If Worksheets("Acct Awaiting 2 week review").Cells(j, 2).Value = Worksheets("MIV Case Details").Cells(i, 2).Value Then
            MsgBox ("Found It")
        
                Worksheets("MIV Case Details").Cells(j, 14).Value = Worksheets("Acct Awaiting 2 week review").Cells(i, 14).Value
            Else
            End If
    Next i
Next j
End Sub

 

[JackDanIce]

Try this instead:

Private Sub CommandButton1_Click()

    Dim dic     As Object
    Dim arr()   As Variant
    Dim x       As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    With Worksheets("Acct Awaiting 2 week review")
        x = .Cells(.Rows.Count, 2).End(xlUp).row
        arr = .Cells(1, 2).Resize(x, 13).Value
    End With
    
    For x = LBound(arr, 1) To UBound(arr, 1)
        dic(arr(x, 1)) = arr(x, 13)
    Next x
    Erase arr
    
    With Worksheets("MIV Case Details")
        x = .Cells(.Rows.Count, 2).End(xlUp).row
        arr = .Cells(1, 2).Resize(x).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            arr(x, 1) = dic(arr(x, 1))
        Next x
        .Cells(1, 14).Resize(UBound(arr, 1)).Value = arr
    End With
    Erase arr
    
    Set dic = Nothing

End Sub

 

[sazza]

that works perfectly - Thanks a mill JackDanIce ...

If you have time would you be able to add some comments for me to understand the logic please ?

 

[JackDanIce]

You're welcome and comments added. Think of a dictionary as a 2 column VLOOKUP table, where the position of either the key or the mapped value does not matter. Then for output, you use the dictionary to test if the key value exists and if so, return it's mapped value:

Private Sub CommandButton1_Click()
    
    'Create variables for use in code
    Dim dic     As Object
    Dim arr()   As Variant
    Dim x       As Long
    
    'A dictionary is a data object that maps a unique key to a value
    Set dic = CreateObject("Scripting.Dictionary")
    
    'Read the Key (col B) and Value (col N) into an array
    With Worksheets("Acct Awaiting 2 week review")
        x = .Cells(.Rows.Count, 2).End(xlUp).row
        arr = .Cells(1, 2).Resize(x, 13).Value
    End With
    
    'Populate dictionary with key (col B) and item (col N)
    For x = LBound(arr, 1) To UBound(arr, 1)
        dic(arr(x, 1)) = arr(x, 13)
    Next x
    Erase arr
    
    'Read the keys that require a map in the MIV Case Details sheet
    'into an array. Loop this array through the dictionary
    'and overwrite the existing key value in the array with it's mapped value
    'Finally, print results to col N
    With Worksheets("MIV Case Details")
        x = .Cells(.Rows.Count, 2).End(xlUp).row
        arr = .Cells(1, 2).Resize(x).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            arr(x, 1) = dic(arr(x, 1))
        Next x
        .Cells(1, 14).Resize(UBound(arr, 1)).Value = arr
    End With
    
    'Clear variables
    Erase arr
    Set dic = Nothing


End Sub

 

[sazza]

Thanks JackDanIce ... so in theory to adapt this code to other tabs and other columns I should just need to amend these bits ?

With Worksheets("Acct Awaiting 2 week review")

and

Column N = 13 so change this to say column K = 10 ? like here :

arr = .Cells(1, 2).Resize(x, 13).Value

Thanks for all your help on this - arrays go way over my level of newbie knowledge ...

 

[JackDanIce]

Yes, that's correct.

 

[sazza]

I have just one issue when I replicate it onto another sheet in that....

if I update K for one cell on "Acct Awaiting initial review" and run this macro it updates that cell on "MIV Case Details" but it also clears all the other information in column K on "MIV Case Details" ?

This was happening to me last night too but I thought I was doing something stupid I would spot with fresh eyes this morning .... That didn't happen...

Private Sub CommandButton2_Click()

    
    'Create variables for use in code
    Dim dic     As Object
    Dim arr()   As Variant
    Dim x       As Long
    
    'A dictionary is a data object that maps a unique key to a value
    Set dic = CreateObject("Scripting.Dictionary")
    
    'Read the Key (col B) and Value (col N) into an array
    With Worksheets("Acct Awaiting initial review")
        x = .Cells(.Rows.count, 2).End(xlUp).Row
        arr = .Cells(1, 2).Resize(x, 10).Value ' K = 11 -1
    End With
    
    'Populate dictionary with key (col B) and item (col N)
    For x = LBound(arr, 1) To UBound(arr, 1)
        dic(arr(x, 1)) = arr(x, 10) ' K = 11 -1
    Next x
    Erase arr
    
    'Read the keys that require a map in the MIV Case Details sheet
    'into an array. Loop this array through the dictionary
    'and overwrite the existing key value in the array with it's mapped value
    'Finally, print results to col N
    With Worksheets("MIV Case Details")
        x = .Cells(.Rows.count, 2).End(xlUp).Row
        arr = .Cells(1, 2).Resize(x).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            arr(x, 1) = dic(arr(x, 1))
        Next x
        .Cells(1, 11).Resize(UBound(arr, 1)).Value = arr ' K = 11
    End With
    
    'Clear variables
    Erase arr
    Set dic = Nothing

End Sub