OzGrid

How to find one value with another workbook and copy correspondent value

Requirement:

There are two workbooks which the user refers to  as workbook 1 and workbook 2. What the user needs to get done is there are some values in column "B" of workbook 1, and the user needs to find these values from column "I" of workbook 2 and copy correspondent value of column "K" of workbook 2 and paste it to the column "C" of workbook 01. Below code does not respond me when the user runs the macro.

How does the user change this?

Option Explicit


Public Sub FindColAndOffset()

    Const B = "B"
    Const I = "I"
    Const C = 2
    Const K = 15

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lr1 As Long
    Dim lr2 As Long
    
    Set ws1 = Workbooks("AAA.xlsx").Worksheets("Sheet1")
    Set ws2 = Workbooks("BBB.xlsx").Worksheets("Sheet1")
    lr1 = ws1.Cells(ws1.Rows.Count, B).End(xlUp).Row
    lr2 = ws2.Cells(ws2.Rows.Count, I).End(xlUp).Row

    Dim itm1 As Range, itm2 As Range

    Application.ScreenUpdating = False
    For Each itm2 In ws2.Range(ws2.Cells(1, I), ws2.Cells(lr2, I))      'workbook 2
    For Each itm1 In ws1.Range(ws1.Cells(1, B), ws1.Cells(lr1, B))  'workbook 1
    If Not IsError(itm1) And Not IsError(itm2) Then
    If InStr(1, itm2.Value2, itm1.Value2) > 0 Then
    itm1.Offset(, C).Formula = itm2.Offset(, K).Formula 'Here.C = workbookBook2.K
                    Exit For
                End If
            End If
        Next
    Next
    Application.ScreenUpdating = True
End Sub

Solution:

 Public Sub FindColAndOffset()
 Dim ws1 As Worksheet  Dim ws2 As Worksheet
 Dim itm1 As Range, itm2 As Range
 Dim dic as object
 Set ws1 = Workbooks("AAA.xlsx").Worksheets("Sheet1")
 Set ws2 = Workbooks("BBB.xlsx").Worksheets("Sheet1")
 Set dic = CreateObject("Scripting.dictionary")
    For Each itm2 In ws2.Columns("i").specialcells(2)        'workbook 2 columns(i) change is needed
          set dic(cstr(itm2.Value)) = itm2.offset(,2)  'OFFSET to columns k  'i dont know your type data as date,time or ? if using date convert cdbl(cdate(....
    Next itm2

     For Each itm1 In ws1.Columns("B").specialcells(2)    'workbook1 columns(b) change is needed
        If dic.exists(cstr(itm1.Value2)) Then    'i dont know your tipe data if time,date convert to cdate,datevalue,
            itm1.Offset(, 3).Formula = "=" & dic(cstr(itm1.value)).Address(external:=True)
        End if  
     Next itm1

  End Sub

Obtained from the OzGrid Help Forum.

Solution provided by graha_karya.

See also: Index to Excel VBA Code and Index to Excel Freebies and Lesson 1 - Excel Fundamentals and Index to how to… providing a range of solutions and Index to new resources and reference sheets

See also:

Click here to visit our Free 24/7 Excel/VBA Help Forum where there are thousands of posts you can get information from, or you can join the Forum and post your own questions.

Gallery