Macro to grab data from two workbooks into master workbook

[Venus Lee]

hello everyone...
I'm looking for a solution for a VBA solution for my scenario which currently can be done by using formula (thank you in advance) :-

My scenario:
1. I need to transfer data from workbook A and workbook B into workbook C. based on two criteria for each selected column in workbook C
criteria 1: the header in column B,C and D in workbook C
criteria 2: the code in column A in workbook C
Example:-
data source workbook A:

data source workbook B:

output workbook C:
I will do a formula to lookup refer to column A into column B,C and D, as you noticed the sequence of the header and code is different too.
The formula I use:
for column B =XLOOKUP(A:A,[workbook A]Sheet1!$A:$A,[workbook A]Sheet1!$C:$C)
for column C =XLOOKUP(A:A,[workbook A]Sheet1!$A:$A,[workbook A]Sheet1!$B:$B)
for column D =XLOOKUP(A:A,[workbook B]Sheet1!$A:$A,[workbook A]Sheet1!$B:$B)

I am looking for a VBA solution that can:-
1. Browse the data source workbook A and workbook B without need to manually open the file
2. Copy paste value the data from workbook A and workbook B into workbook C based on below criteria into the empty cell in range B2:D7
criteria 1: the header in column B,C and D in workbook C
criteria 2: the code in column A in workbook C
3. If the data is not found for the code, for example data for code 113 is not found in workbook A, cell B2 remain empty and continue to work on code 116, so on and on.
4. At the end of the macro:-
a. provide a message if any column is not found, if successfully found all columns, provide a successful message.
b. close workbook A and workbook B

 

[eiloken]

i don't think the idea that display message what code not found because if you have large data, you can not remember all of them after close the message, so i create code that will change cell color that not found:

Sub MergeData()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim wbA As Workbook, wbB As Workbook
    Dim cll As Range, rng As Range, cllA As Range, rngA As Range, cllB As Range, rngB As Range
    ThisWorkbook.Sheets(1).UsedRange.Interior.Color = xlNone 'reset cell color
    Set wbA = Workbooks.Open("Your workbook A path") 'change to your path
    Set wbB = Workbooks.Open("Your workbook B path") 'change to your path
    Set rng = ThisWorkbook.Sheets(1).Range("A2:A" & lr(ThisWorkbook.Sheets(1), 1))
    Set rngA = wbA.Sheets(1).Range("A2:A" & lr(wbA.Sheets(1), 1))
    Set rngB = wbB.Sheets(1).Range("A2:A" & lr(wbB.Sheets(1), 1))
    For Each cll In rng
        If Not rngA.Find(cll.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True) Is Nothing Then
            Set cllA = rngA.Find(cll.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
            If Not rngB.Find(cll.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True) Is Nothing Then
                Set cllB = rngB.Find(cll.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
                cll.Offset(, 3).Value = cllB.Offset(, 1).Value 'amount
            Else
                cll.Offset(, 3).Interior.Color = RGB(255, 0, 0) ' if not found code in workbook B then change cell color to red
            End If
            cll.Offset(, 1).Value = cllA.Offset(, 2).Value 'rating
            cll.Offset(, 2).Value = cllA.Offset(, 1).Value 'comment
        Else
            cll.Offset(, 1).Interior.Color = RGB(255, 0, 0) ' if not found code in workbook A then change cell color to red
            cll.Offset(, 2).Interior.Color = RGB(255, 0, 0)
        End If
    Next cll
    MsgBox "Completed"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Private Function lr(ByVal ws As Worksheet, ByVal col As Integer) As Long
    lr = ws.Cells(Rows.Count, col).End(xlUp).Row
End Function

 

[Venus Lee]

hello eiloken... thanks for your code. i would like to clarify further.

1. can i browse the file instead of fixing the path on the code?
2. it should be ok if the code is not found but most important when the header is not found.
For example, in my output file, it can't find any data belongs to column "rating", it could be due to mismatch header name. Workbook C can't find any rating data in Workbook A because the header in Workbook A is Rate instead of rating. So the header can be dynamic.

i don't think the idea that display message what code not found because if you have large data, you can not remember all of them after close the message, so i create code that will change cell color that not found:

Sub MergeData()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim wbA As Workbook, wbB As Workbook
    Dim cll As Range, rng As Range, cllA As Range, rngA As Range, cllB As Range, rngB As Range
    ThisWorkbook.Sheets(1).UsedRange.Interior.Color = xlNone 'reset cell color
    Set wbA = Workbooks.Open("Your workbook A path") 'change to your path
    Set wbB = Workbooks.Open("Your workbook B path") 'change to your path
    Set rng = ThisWorkbook.Sheets(1).Range("A2:A" & lr(ThisWorkbook.Sheets(1), 1))
    Set rngA = wbA.Sheets(1).Range("A2:A" & lr(wbA.Sheets(1), 1))
    Set rngB = wbB.Sheets(1).Range("A2:A" & lr(wbB.Sheets(1), 1))
    For Each cll In rng
        If Not rngA.Find(cll.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True) Is Nothing Then
            Set cllA = rngA.Find(cll.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
            If Not rngB.Find(cll.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True) Is Nothing Then
                Set cllB = rngB.Find(cll.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
                cll.Offset(, 3).Value = cllB.Offset(, 1).Value 'amount
            Else
                cll.Offset(, 3).Interior.Color = RGB(255, 0, 0) ' if not found code in workbook B then change cell color to red
            End If
            cll.Offset(, 1).Value = cllA.Offset(, 2).Value 'rating
            cll.Offset(, 2).Value = cllA.Offset(, 1).Value 'comment
        Else
            cll.Offset(, 1).Interior.Color = RGB(255, 0, 0) ' if not found code in workbook A then change cell color to red
            cll.Offset(, 2).Interior.Color = RGB(255, 0, 0)
        End If
    Next cll
    MsgBox "Completed"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Private Function lr(ByVal ws As Worksheet, ByVal col As Integer) As Long
    lr = ws.Cells(Rows.Count, col).End(xlUp).Row
End Function

 

[eiloken]

hello eiloken... thanks for your code. i would like to clarify further.

1. can i browse the file instead of fixing the path on the code?
2. it should be ok if the code is not found but most important when the header is not found.
For example, in my output file, it can't find any data belongs to column "rating", it could be due to mismatch header name. Workbook C can't find any rating data in Workbook A because the header in Workbook A is Rate instead of rating. So the header can be dynamic.

View attachment 102350

1. if you want to browse file A and B then you need to set condition for it, that macro will identified those file as workbook A and workbook B.
2. the code above just het data from column number, not detect as column title, if input file form has data in same column so it will be OK.

 

[jolivanes]

Please don't make it any more difficult by quoting. Just not needed to clutter it all up.

Another possibility. As per Post #1
Change references where required.

Sub Maybe_So()
Dim sh1 As Worksheet, sh2 As Worksheet, sh4 As Worksheet, wbA As Workbook
Dim arr1, arr2, arr3, i As Long, missing
Application.ScreenUpdating = False
Set wbA = ThisWorkbook
Set sh4 = wbA.Worksheets("Sheet4")    '<---- Change(s) required.
Set sh1 = Workbooks.Open("C:\Some Folder Name\Some File Name 1.xlsm").Sheets("Sheet1")    '<---- Change(s) required.
Set sh2 = Workbooks.Open("C:\Some Folder Name\Some File Name 2.xlsm").Sheets("Sheet1")    '<---- Change(s) required.
arr1 = sh1.Cells(1).CurrentRegion.Columns(1).Resize(, 3).Value
arr2 = sh2.Cells(1).CurrentRegion.Columns(1).Resize(, 2).Value
arr3 = sh4.Cells(1).CurrentRegion.Columns(1).Resize(, 4).Value
    For i = 2 To UBound(arr3)
        If Not Application.IsError(Application.Match(arr3(i, 1), sh1.Cells(1).CurrentRegion.Columns(1), 0)) = 0 Then
            missing = missing & "|" & arr3(i, 1)
                Else
            arr3(i, 2) = sh1.Columns(1).Find(arr3(i, 1), , , 1).Offset(, 2).Value
            arr3(i, 3) = sh1.Columns(1).Find(arr3(i, 1), , , 1).Offset(, 1).Value
            arr3(i, 4) = sh2.Columns(1).Find(arr3(i, 1), , , 1).Offset(, 1).Value
        End If
    Next i
Workbooks("Some File Name 1.xlsm").Close False    '<---- Change(s) required.
Workbooks("Some File Name 2.xlsm").Close False    '<---- Change(s) required.
sh4.Range("A1").Resize(UBound(arr3), 4).Value = arr3
Application.ScreenUpdating = True
MsgBox "Missing:" & vbCrLf & Join(Split(Mid(missing, 2), "|"), vbCrLf)
End Sub

Just read that you want changes made that were not in Post #1. That will have to wait until after the holidays.