Merging two spreadsheets after a button click

Question

I have 2 spreadsheets:

main.xlsxm

drs.xlsx

I am trying to merge the two spreadsheets - this event will be launched after a button click on the main.xlsx spreadsheet (so the VBA code will reside on main.xlsx).

But I'm having difficulty writing my code, I originally tried using a variation of the following Excel formula but it was incredibly slow.

=IFERROR(INDEX([1.xlsx]Sheet1!$A:$A,SMALL(IF([1.xlsx]Sheet1!$B:$B=$A2,ROW([1.xlsx]Sheet1!$B:$B),99^99),COLUMN(A$1))),"")

I am trying to accomplish the following in VBA:

If column value E in drs.xlsx equals column value A in main.xlsx: Then on the matching row in main.xlsx Copy column value B in drs.xls to column value J in main.xlsx

If a second match is found (provided it is not the same as the first match): Where column value E in drs.xlsx equals column value A in main.xlsx Copy column value B in drs.xls to column value K in main.xlsx

If a third match is found (provided it is not the same as the first and second match): Where column value E in drs.xlsx equals column value A in main.xlsx Copy column value B in drs.xls to column value L in main.xlsx

If it happens for a fourth time then ignore…

How would I articulate this as VBA code?

This is my code so far (which prepares the spreadsheet ready):

Sub DRS_Update()
    Dim wb As Workbook

    Set wb = Workbooks.Open("C:\drs.xlsx")

    With wb.Worksheets("Sheet1")
        .AutoFilterMode = False
        With .Range("A1:D1")
            .AutoFilter Field:=1, Criteria1:="TW", Operator:=xlOr, Criteria2:="W"
            .AutoFilter Field:=3, Criteria1:="Windows 7", Operator:=xlOr, Criteria2:="Windows XP"
            .AutoFilter Field:=4, Criteria1:="Workstation-Windows"
        End With
    End With
End Sub

Answer 1

Try following code. I've commented it in details, but if you have some questions, feel free to ask in comments:)

Sub test()
    Dim wb As Workbook
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim user As Range

    Dim lastrowDRS As Long, lastrowMAIN As Long
    Dim rng As Range, res As Range
    Dim k As Byte
    Dim fAddr As String

    Application.ScreenUpdating = False

    'specify sheet name for main workbook
    Set sh1 = ThisWorkbook.Worksheets("Sheet1")

    'if drs is already opened
    'Set wb = Workbooks("drs.xlsx")
    'if drs not already opened
    Set wb = Workbooks.Open("C:\drs.xlsx")

    'specify sheet name for drs workbook
    Set sh2 = wb.Worksheets("Sheet1")


    With sh1
        'find last row on column A in main wb
        lastrowMAIN = .Cells(.Rows.Count, "A").End(xlUp).Row

        'clear prev data in columns J:L
        .Range("J1:L" & lastrowMAIN).ClearContents
    End With

    With sh2
        .AutoFilterMode = False
        'find last row on column A in drs wb
        lastrowDRS = .Cells(.Rows.Count, "A").End(xlUp).Row

        'apply filter
        With .Range("A1:D1")
            .AutoFilter Field:=1, Criteria1:="TW", Operator:=xlOr, Criteria2:="W"
            .AutoFilter Field:=3, Criteria1:="Windows 7", Operator:=xlOr, Criteria2:="Windows XP"
            .AutoFilter Field:=4, Criteria1:="Workstation-Windows"
        End With

        On Error Resume Next
        'get only visible rows in column E
        Set rng = .Range("E1:E" & lastrowDRS).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0

        'loop throught each user in main wb
        For Each user In sh1.Range("A1:A" & lastrowMAIN)
            'counter for finding entries
            k = 0
            'find first match
            Set res = rng.Find(what:=user.Value, MatchCase:=False)
            If Not res Is Nothing Then
                'remember address of first match
                fAddr = res.Address
                Do
                    'user.Offset(, 9 + k) gives you column J for k=0, K for k=1, L for k=2
                    user.Offset(, 9 + k).Value = res.Offset(, -3).Value
                    'increment k
                    k = k + 1
                    'find next match
                    Set res = rng.FindNext(res)
                    'if nothing found exit stop searcing entries for current user
                    If res Is Nothing Then Exit Do
                'if we already found 3 mathes, then stop search for current user
                Loop While fAddr <> res.Address And k < 3
            End If
        Next user
    End With

    'close drs wb without saving changes
    wb.Close saveChanges:=False
    Set wb = Nothing

    Application.ScreenUpdating = True
End Sub