Consolidate multiple workbooks from a folder into one master file VBA

[Admin]

Hi All,

Here is sub which will consolidate multiple workbooks from a single folder into a master workbook.

It even handles the different col headers while consolidating.


Dim dic As Object
Dim Counter As Long
Sub ConsolidateWorkbooks()

Dim r As Long
Dim c As Long
Dim n As Long
Dim j As Long
Dim Fldr As String
Dim Fname As String
Dim wbkActive As Workbook
Dim wbkSource As Workbook
Dim Dest As Range
Dim d, k()

'// User settings
Const SourceFileType As String = "xls*" 'xls,xlsx,xlsb,xlsm
Const DestinationSheet As String = "Sheet1"
Const DestStartCell As String = "A1"
Const MaxRows As Long = 50000
Const MaxCols As Long = 100
Const StartRow As Long = 2
'// End

Application.ScreenUpdating = False
Counter = 0
With Application.FileDialog(4)
.Title = "Select source file folder"
.AllowMultiSelect = False
If .Show = -1 Then
Fldr = .SelectedItems(1)
Else
GoTo Xit
End If
End With


Set dic = CreateObject("scripting.dictionary")
dic.comparemode = 1

Set wbkActive = ThisWorkbook

ReDim k(1 To MaxRows, 1 To MaxCols)

Set Dest = wbkActive.Worksheets(DestinationSheet).Range(DestS tartCell)

Fname = Dir(Fldr & "\*." & SourceFileType)

Do While Len(Fname)
If wbkActive.Name <> Fname Then
Set wbkSource = Workbooks.Open(Fldr & "\" & Fname)
With wbkSource.Worksheets(1)
d = .Range("a1").CurrentRegion
UniqueHeaders Application.Index(d, 1, 0)
For r = StartRow To UBound(d, 1)
If Len(d(r, 1)) Then
n = n + 1
For c = 1 To UBound(d, 2)
If Len(Trim$(d(1, c))) Then
j = dic.Item(Trim$(d(1, c)))
k(n, j) = d(r, c)
End If
Next
End If
Next
Erase d
End With
wbkSource.Close 0
Set wbkSource = Nothing
End If
Fname = Dir()
Loop

If n Then
Dest.Resize(, dic.Count) = dic.keys
Dest.Offset(1).Resize(n, dic.Count) = k
MsgBox "Done", vbInformation, "ExcelFox.com"
End If
Xit:
Application.ScreenUpdating = True

End Sub
Private Sub UniqueHeaders(ByRef DataHeader)

Dim i As Long
Dim j As Long

With Application
j = .ScreenUpdating
.ScreenUpdating = False
End With

For i = LBound(DataHeader) To UBound(DataHeader)
If Len(Trim$(DataHeader(i))) Then
If Not dic.exists(Trim$(DataHeader(i))) Then
Counter = Counter + 1
dic.Add Trim$(DataHeader(i)), Counter
End If
End If
Next

Application.ScreenUpdating = j

End Sub

[jazzy747]

I have been searching quite a while for such a code. And this one appears to be perfect, thanks a lot!

Nevertheless I am now looking to change it to a defined folder. Meaning that I'd like to drop the part which allows you to browse to select a folder and instead specify the folder address directly in the code.

Since I am not a very advanced VBA user I don't know how I should handle it since the code is verry condensed.
Thanks for your help.

[Andrew_K99]

Replace


With Application.FileDialog(4)
.Title = "Select source file folder"
.AllowMultiSelect = False
If .Show = -1 Then
Fldr = .SelectedItems(1)
Else
GoTo Xit
End If
End With


With


Fldr = "C:\SubFolder\MyFolder" 'change to the desired location


AK

[jazzy747]

Thanks for the help.

I am now stuck again because I had to modifiy the document layout.
Is there a way to make this code handle the number of columns that should be considered?
I would like to limit the data to columns "A to S" in other words the 19 first columns.
I tried to tweak "MaxCols" but it doesn't work.

Could anyone give me a hint on this please?

Thanks in advance!

[Admin]

Hi

Untested. Replace
d = .Range("a1").CurrentRegion

with


d = .Range("a1").CurrentRegion.resize(,19).value