Consolidation of Workbooks

     

    Features of this template:

  • Enables the user to select required Workbooks and Worksheets
  • It add the files which consists of extension as .XLSX ,.XLSM, XLSB..(Excel Extension only) from the folder
  • It adds unique workbook and worksheet names to the List box
  • It is not mandatory that all the workbooks should consists of equal number of worksheets
  • It copies the workbook and worksheets names in Buttons tab
  • It allows the user to run the program N Number of times as application saves the output by creating new workbook, each and every time

    •  

    Download The Workbook

     

    Public CodingWkb As Workbook, CodingSh As Worksheet
    Public InputWkb As Workbook, InputSh As Worksheet
    Public OutputWkb As Workbook, OutputSh As Worksheet

    Sub Consolidate_Workbooks_and_Worksheets()
    Application.ScreenUpdating = False
    '==========Define Coding Workbook and Worksheet========
    Set CodingWkb = ActiveWorkbook
    Set CodingSh = CodingWkb.Sheets("Buttons")

    If CodingSh.Range("A1").CurrentRegion.Rows.Count > 1 Then
    CodingSh.Range("A2:B" & CodingSh.Range("A" & Rows.Count).End(xlUp).Row).ClearContents
    End If
    '=============Select the folder using FILEDIALOG==========
    Dim FD As FileDialog
    Set FD = Application.FileDialog(msoFileDialogFolderPicker)
    FD.Title = "Select The Workbooks Folder"
    FD.Show
    Dim folderpath As String
    folderpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
    UserForm1.TextBox1.Value = folderpath
    UserForm1.TextBox1.TextAlign = fmTextAlignLeft

    '=====Define the FileName=============================
    Dim Filename As String
    Filename = Dir(folderpath & "*.xl??")

    '======Starts the Do Loop to retrieve the workbook names from the folder=
    Do While Filename <> ""

    UserForm1.ListBox1.AddItem Filename

    'Add the workbook and Worksheet Names to USERFORM

    Workbooks.Open (folderpath & Filename)
    Set InputWkb = ActiveWorkbook
    For i = 1 To InputWkb.Sheets.Count
    AlreadyAddedToListbox = ""
    For L = 0 To UserForm1.ListBox2.ListCount - 1
    If UserForm1.ListBox2.List(L) = InputWkb.Sheets(i).Name Then
    AlreadyAddedToListbox = "Yes"
    Exit For
    End If
    Next
    If AlreadyAddedToListbox <> "Yes" Then
    UserForm1.ListBox2.AddItem InputWkb.Sheets(i).Name
    End If
    Next
    InputWkb.Close


    Filename = Dir
    Loop


    UserForm1.Show

    Application.ScreenUpdating = True
    End Sub

     

     

    Private Sub CommandButton1_Click()
    Unload Me
    End Sub

    Private Sub CommandButton2_Click()

    '===========================================
    'Applying Application Object Properties
    Application.DisplayAlerts = False
    Application.SheetsInNewWorkbook = 1

    '===Save the Selected workbook names in a variable based on Listbox Selection========
    Dim TotalWorkbooks As String
    TotalWorkbooks = ""
    For i = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) = True Then
    TotalWorkbooks = TotalWorkbooks & "," & Me.ListBox1.List(i)
    End If
    Next
    TotalWorkbooks = Right(TotalWorkbooks, Len(TotalWorkbooks) - 1)

    '=======Save The Worksheet names in a variable based on List box Selection===============
    Dim TotalWorksheets As String
    TotalWorksheets = ""
    For i = 0 To ListBox2.ListCount - 1
    If ListBox2.Selected(i) = True Then
    TotalWorksheets = TotalWorksheets & "," & Me.ListBox2.List(i)
    End If
    Next
    TotalWorksheets = Right(TotalWorksheets, Len(TotalWorksheets) - 1)
    folderpath = UserForm1.TextBox1.Value
    '==============Unload the Userform====================
    Unload Me
    '=======Create new workbook for Output=================
    Set OutputWkb = Workbooks.Add
    sh = 1
    OutputWkb.Sheets(sh).Activate
    Last = OutputWkb.Sheets(sh).Range("A" & Rows.Count).End(xlUp).Row
    OutputWkb.Activate
    ActiveWindow.DisplayGridlines = False

    Dim r As Long 'check last row with data
    Dim c As Integer 'identify the last column with data
    Dim fc As Integer, fr As Integer, q As Integer
    fc = 1: fr = 1: q = 1:
    w = 1

    Dim sht As Worksheet
    'Split the workbook and worksheet names based on comma
    PostsplitWorkbooks = Split(TotalWorkbooks, ",")
    PostsplitWorkSheets = Split(TotalWorksheets, ",")
    Dim ShLastRow As Integer

    'External Loop for Workbooks
    For i = 0 To UBound(PostsplitWorkbooks)
    ShLastRow = CodingSh.Range("A" & Rows.Count).End(xlUp).Row + 1

    Filename = PostsplitWorkbooks(i)
    CodingSh.Cells(ShLastRow, 1).Value = Filename
    Workbooks.Open (folderpath & Filename)
    Set InputWkb = ActiveWorkbook

    ' Internal Loop for worksheets
    For j = 0 To UBound(PostsplitWorkSheets)
    s = PostsplitWorkSheets(j)

    'Ensure whether the worksheet exists or not
    For Each sht In InputWkb.Worksheets
    If sht.Name = s Then
    SheetIdentified = "Yes"
    Exit For
    End If
    Next

    '=======================Executes when sheet exists only========================
    If SheetIdentified = "Yes" Then

    For Each sht In OutputWkb.Worksheets
    If sht.Name = s Then
    SheetAlreadyCreated = "Yes"
    Exit For
    End If
    Next

    If SheetAlreadyCreated <> "Yes" Then
    q = 1
    InputWkb.Worksheets(s).Activate
    Lastcol = Range(Range("A" & fc), Range("A" & fc).End(xlToRight)).Columns.Count
    LastRow = Range(Range("A" & fr), Range("A" & fr).End(xlDown)).Rows.Count
    Range(Cells(q, 1), Cells(LastRow, Lastcol)).Select
    Selection.Copy
    If sh > OutputWkb.Sheets.Count Then
    OutputWkb.Activate
    OutputWkb.Worksheets.Add after:=Sheets(Worksheets.Count)
    End If
    OutputWkb.Sheets(sh).Activate
    OutputWkb.Sheets(sh).Range("A1").PasteSpecial Paste:=xlPasteAll
    Application.CutCopyMode = False
    Sheets(sh).Name = s
    sh = sh + 1


    ElseIf SheetAlreadyCreated = "Yes" Then
    If OptionButton1.Value = True Then q = 2
    If OptionButton2.Value = True Then q = 1
    OutputWkb.Sheets(s).Activate
    InputWkb.Worksheets(s).Activate
    Lastcol = Range(Range("A" & fc), Range("A" & fc).End(xlToRight)).Columns.Count
    LastRow = Range(Range("A" & fr), Range("A" & fr).End(xlDown)).Rows.Count
    Range(Cells(q, 1), Cells(LastRow, Lastcol)).Select
    Selection.Copy
    Last = OutputWkb.Sheets(s).Range("A" & Rows.Count).End(xlUp).Row + 1
    OutputWkb.Sheets(s).Range("A" & Last).PasteSpecial Paste:=xlPasteAll
    Application.CutCopyMode = False
    End If
    CodingSh.Cells(ShLastRow, 2).Value = CodingSh.Cells(ShLastRow, 2).Value & "," & s
    End If
    '============================================================
    SheetIdentified = ""
    SheetAlreadyCreated = ""
    Next ' List box 2 loop close
    InputWkb.Close
    If Len(CodingSh.Cells(ShLastRow, 2)) > 0 Then
    CodingSh.Cells(ShLastRow, 2).Value = Right(CodingSh.Cells(ShLastRow, 2), Len(CodingSh.Cells(ShLastRow, 2)) - 1)
    End If

    w = w + 1

    Next

    For q = 1 To OutputWkb.Sheets.Count
    OutputWkb.Sheets(q).Activate
    OutputWkb.Sheets(q).UsedRange.Select
    With Selection
    .Font.Size = 18
    .Font.Name = "Footlight MT Light"
    .Cells.EntireColumn.AutoFit
    .Cells.Borders.ColorIndex = 1
    .Cells.Borders.LineStyle = xlContinuous
    .Cells.Borders.Weight = 3
    ActiveWindow.DisplayGridlines = False
    End With
    OutputWkb.Sheets(q).Range("A1").Select
    Next

    Dim SavedTime As String
    SavedTime = Format(Now(), "YYYY_MM_DD_HH_SS")
    OutputWkb.SaveAs Filename:="OutputWkb_" & SavedTime & ".xlsx"

    Application.SheetsInNewWorkbook = 3
    Application.DisplayAlerts = True

    End Sub



     

     

     

     

     

     

Hi Everyone,
Welcome to VBA Macros Tutorial. This Tutorial provides comprehensive knowledge on VBA Macros to the user. Hope it enhances your coding skills. If you like this web page kindly Share this to your near and dear. I Prepared this content as per my level of knowledge, if any changes required kindly bring to my notice. Thanks for visiting this web page

Thanks,
Pavan Kumar Gundlapalli