VBA code to search for a column data from one sheet to another and paste corresponding rows data onto first sheet

Question

I am new to VBA and i am not able to find any solution to my problem. I have two workbooks with data. In workbook1 there is a name column A.In workbook2 there is also a name columnA and other data from column B to D. I need to search name from Column A of workbook2 in column A of workbook 1 and if the name matches I need to paste the corresponding rows in workbook1. Also please note that In workbook2 there may be more than one entry for same name.. so in those cases those row values must be concatenated and pasted on workbook1.

Please help

Dim AVals As New Dictionary Dim k As Long, j As Long, lastRow1 As Long, lastRow2 As Long Dim sh_1, sh_3 As Worksheet Dim MyName As String Dim tmpCollection As Collection Set sh_1 = Sheets("snipe-sample-assets blank") Dim key As Variant

inputRowMin = 1
inputRowMax = 288
inputColMin = 1
inputColMax = 9
equipmentCol = 4
dimensionCol = 9

Set equipmentDictionary = CreateObject("Scripting.Dictionary")
equipmentDictionary.CompareMode = vbTextCompare
Set inputSheet = Application.Sheets("Verizon WirelessNumbers_2021033")
Set inputRange = Range(Cells(inputRowMin, inputColMin), Cells(inputRowMax, inputColMax))
Set equipmentCollection = New Collection

For i = 1 To inputRange.Height
    thisEquipment = inputRange(i, equipmentCol).Text
    nextEquipment = inputRange(i + 1, equipmentCol).Text
    thisDimension = inputRange(i, dimensionCol).Text

    'The Strings are equal - add thisEquipment to collection and continue
    If (StrComp(thisEquipment, nextEquipment, vbTextCompare) = 0) Then
        equipmentCollection.Add thisDimension
    'The Strings are not equal - add thisEquipment to collection and the collection to the dictionary
    Else
        equipmentCollection.Add thisDimension
        equipmentDictionary.Add thisEquipment, equipmentCollection
        Set equipmentCollection = New Collection
    End If

Next

'Set sh_3 = Sheets("sheet2")

lastRow2 = sh_1.Range("A:A").Rows.Count
lastRow2 = sh_1.Cells(lastRow2, 2).End(xlUp).Row 'last used row in column 2
'MsgBox lastRow2

For j = 2 To lastRow2
    MyName = UCase(sh_1.Cells(j, 2).Value)
    For Each key In equipmentDictionary.Keys
        If (StrComp(MyName, key, vbTextCompare) = 0) Then
            Set tmpCollection = equipmentDictionary.Item(MyName)
            For k = 1 To tmpCollection.Count
                sh_1.Cells(j, 10).Value = tmpCollection.Item(k)
            Next
        End If
        
    Next
    
Next j

What have you tried? Have you been able to open and read cells from both workbooks in VBA? — Amiga500
I brought both workbooks data onto one workbook in different sheets.. but not able to implement above logic — Priya Mukherjee
Welcome to SO. Please be aware that SO is meant to be an assistance repository. So it would help if you can show what code you have already tried. What errors do you get, what solutions have you tried etc. Without any code at all nobody will be able to assist. Moreover, this question, or similar ones have been asked many times. Have you done any research on how others have solved the issue? stackoverflow.com/… — mtholen

Amiga500 Amiga500 · Accepted Answer · 2021-04-01T11:21:11

Quick run down of what you need

'You declare all these based on where your data resides
sheetName1 = "Sheets1"
sheetName2 = "Sheets2"
wbName1 = activeworkbook.name
wbName2 = activeworkbook.name   'I've included this for where you might want to fork solution to work off two workbooks

'Loop through entries in sheetName1
iRows1 = 1
Do Until IsEmpty(workbooks(wbName1).sheets(sheetName1).cells(iRows1,1))
    sourceName = workbooks(wbName1).sheets(sheetName1).cells(iRows1,1)

    'Loop through entries in sheetName2
    colB = ""
    colC = ""
    colD = ""
    iRows2 = 1
    Do Until IsEmpty(workbooks(wbName2).sheets(sheetName2).cells(iRows2,1))
        if workbooks(wbName2).sheets(sheetName2).cells(iRows2,1) = sourceName then
            'If there is a match then append. If you want to delimit, then you'd need to add in a delimiter & "," for example
            colB = colB & workbooks(wbName2).sheets(sheetName2).cells(iRows2,2).text
            colC = colC & workbooks(wbName2).sheets(sheetName2).cells(iRows2,3).text
            colD = colD & workbooks(wbName2).sheets(sheetName2).cells(iRows2,4).text
        end if
        iRows2 = iRows2 + 1
    Loop

    if colB <> "" then
        'Found something, send it to sheetName1
        workbooks(wbName1).sheets(sheetName1).cells(iRows1,2) = colB
        workbooks(wbName1).sheets(sheetName1).cells(iRows1,3) = colC
        workbooks(wbName1).sheets(sheetName1).cells(iRows1,4) = colD
    end if

    iRows1 = iRows1 + 1
Loop

If you want to do it for separate workbooks, then you need to assign a wbName2. My use of ActiveWorkbook assumes it'll be run out of the workbook you are pasting to. It also assumes you've opened both workbooks. You can figure that bit out yourself I'm sure.

VBA code to search for a column data from one sheet to another and paste corresponding rows data onto first sheet

1 Answers