Merge multiple Excel workbooks into single masterlist - excel

Question

I have the following code albeit incomplete as i am unsure how i can populate multiple columns and rows.
Code
Sub VlookMultipleWorkbooks()
Dim lookFor As Range
Dim srchRange As Range
Dim book1 As Workbook
Dim book2 As Workbook
Dim book1Name As String
book1Name = "destination.xls" 'modify it as per your requirement
Dim book1NamePath As String
book1NamePath = ThisWorkbook.Path & "\" & book1Name
Dim book2Name As String
book2Name = "source.xls" 'modify it as per your requirement
Dim book2NamePath As String
book2NamePath = ThisWorkbook.Path & "\" & book2Name
' Set book1 = ThisWorkbook
Set book1 = Workbooks(book1Name)
If IsOpen(book2Name) = False Then Workbooks.Open (book2NamePath)
Set book2 = Workbooks(book2Name)
Set lookFor = book1.Sheets(1).Cells(2, 1) ' value to find
Set srchRange = book2.Sheets(1).Range("A:B") 'source
lookFor.Offset(0, 1).Value = Application.VLookup(lookFor, srchRange, 2, False)
End Sub
My source file has the following structure
Name Value1
My destination file has the following structure
Name Value1
Problem 1
Currently the code only populates a single cell where i would like it to populate allow rows.
Problem 2
I need to be able to populate multiple columns. For example.
Name Value1 Value2, etc
Problem 3
There are multiple source files that need to merge into a single master list.

Answer 1

EDIT: You could modify your initial design to take in two Range objects and an offset, then iterate as necessary. You'll need to open your workbooks and assign the Range objects elsewhere, but that doesn't seem to be the challenge right now. (Below is untested):
Sub EvenCoolerVLookup(SourceRange As Range, OffsetColumns As Long, LookupRange As Range)
Dim Cell As Range
'vet range objects and make sure they fail an Is Nothing test
'....
For Each Cell In SourceRange
'do any special prep here
'...
Cell.Offset(0, OffsetColumns).Value = Application.VLookup(Cell, LookupRange, 2, False)
'do any special cleanup here
'...
Next Cell
'do anything else here
'....
End Sub
That should help you solve Problem 1. To solve Problem 2, you won't be able to use Application.Vlookup, but you can instead use Range.Find to return a Range object, from which you can grab the row via Range.Row.
Original Response: This should work to combine source files for Problem 3. The results will be saved as an xlsx file to the same directory as the file from which the code is run:
Option Explicit
'let's do some combining y'all!
Sub CombineSelectedFiles()
Dim TargetFiles As FileDialog
Dim TargetBook As Workbook, CombinedBook As Workbook
Dim TargetSheet As Worksheet, CombinedSheet As Worksheet
Dim TargetRange As Range, AddNewRange As Range, _
FinalRange As Range
Dim LastRow As Long, LastCol As Long, Idx As Long, _
LastCombinedRow As Long
Dim CombinedFileName As String
Dim RemoveDupesArray() As Variant
'prompt user to pick files he or she would like to combine
Set TargetFiles = UserSelectMultipleFiles("Pick the files you'd like to combine:")
If TargetFiles.SelectedItems.Count = 0 Then Exit Sub '<~ user clicked cancel
'create a destination book for all the merged data
Set CombinedBook = Workbooks.Add
Set CombinedSheet = CombinedBook.ActiveSheet
'loop through the selected workbooks and combine data
For Idx = 1 To TargetFiles.SelectedItems.Count
Set TargetBook = Workbooks.Open(TargetFiles.SelectedItems(Idx))
Set TargetSheet = TargetBook.ActiveSheet
If Idx = 1 Then
TargetSheet.Cells.Copy Destination:=CombinedSheet.Cells(1, 1)
Else
LastRow = FindLastRow(TargetSheet)
LastCol = FindLastCol(TargetSheet)
With TargetSheet
Set TargetRange = .Range(.Cells(2, 1), .Cells(LastRow, LastCol))
End With
LastCombinedRow = FindLastRow(CombinedSheet)
With CombinedSheet
Set AddNewRange = .Range(.Cells(LastCombinedRow + 1, 1), _
.Cells(LastCombinedRow + 1 + LastRow, LastCol))
End With
TargetRange.Copy Destination:=AddNewRange
End If
TargetBook.Close SaveChanges:=False
Next Idx
'set up a final range for duplicate removal
LastCombinedRow = FindLastRow(CombinedSheet)
With CombinedSheet
Set FinalRange = .Range(.Cells(1, 1), .Cells(LastCombinedRow, LastCol))
End With
'populate the array for use in the duplicate removal
ReDim RemoveDupesArray(LastCol)
For Idx = 0 To (LastCol - 1)
RemoveDupesArray(Idx) = Idx + 1
Next Idx
FinalRange.RemoveDuplicates Columns:=Evaluate(RemoveDupesArray), Header:=xlYes
'save the results
CombinedFileName = ThisWorkbook.Path & "\Combined_Data"
Application.DisplayAlerts = False
CombinedBook.SaveAs FileName:=CombinedFileName, FileFormat:=51
CombinedBook.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
'prompt user to select files then return the selected fd object
Public Function UserSelectMultipleFiles(DisplayText As String) As FileDialog
Dim usmfDialog As FileDialog
Set usmfDialog = Application.FileDialog(msoFileDialogOpen)
With usmfDialog
.AllowMultiSelect = True
.Title = DisplayText
.ButtonName = ""
.Filters.Clear
.Filters.Add ".xlsx files", "*.xlsx"
.Filters.Add ".xlsb files", "*.xlsb"
.Filters.Add ".xlsm files", "*.xlsm"
.Filters.Add ".xls files", "*.xls"
.Filters.Add ".csv files", "*.csv"
.Filters.Add ".txt files", "*.txt"
.Show
End With
Set UserSelectMultipleFiles = usmfDialog
End Function
'identify last row in a worksheet
Public Function FindLastRow(Sheet As Worksheet) As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
FindLastRow = Sheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Else
FindLastRow = 1
End If
End Function
'identify last col in a worksheet
Public Function FindLastCol(Sheet As Worksheet) As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
FindLastCol = Sheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Else
FindLastCol = 1
End If
End Function