Consolidation of Worksheets

  • First create a folder on your desktop
  • In that folder place the coding workbook along with Input workbook
  •  

    Download The Workbook

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

    Sub Consolidate_Worksheets()
    Application.ScreenUpdating = False

    '==========Define Coding Workbook and Worksheet========
    Set CodingWkb = ActiveWorkbook
    Set CodingSh = CodingWkb.Sheets("Buttons")

    '===========Delete the worksheet names data in buttons tab
    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 Workbook==========
    Dim fileName As String
    fileName = Application.GetOpenFilename()
    UserForm1.TextBox1.Value = fileName
    UserForm1.TextBox1.TextAlign = fmTextAlignLeft

    '============Open the Workbook============
    Workbooks.Open (fileName)
    Set InputWkb = ActiveWorkbook
    Dim Sh As Worksheet
    For Each Sh In InputWkb.Worksheets
    UserForm1.ListBox1.AddItem Sh.Name
    Next
    UserForm1.Show
    Application.SheetsInNewWorkbook = 3
    Application.ScreenUpdating = True
    End Sub

    Private Sub CommandButton1_Click()
    Unload Me
    End Sub

    Function Nullifying_The_Variables()
    NewWorkbook = ""
    Header = ""
    TotalWorkSheets = ""
    Set CodingWkb = Nothing
    Set CodingSh = Nothing
    Set InputWkb = Nothing
    Set InputSh = Nothing
    Set OutputWkb = Nothing
    Set OutputSh = Nothing
    q = 0
    fr = 0
    fc = 0
    i = 0
    End Function

     

     

     

     

     

     

    Private Sub CommandButton1_Click()

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

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

    '=======Define the output workbook based on Option button selection
    SavedTime = Format(Now(), "YYYY_MM_DD_HH_SS")

    If Me.OptionButton1.Value = True Then
    NewWorkbook = "Yes"
    Set OutputWkb = Workbooks.Add
    Set OutputSh = OutputWkb.ActiveSheet
    OutputSh.Name = "Consolidated" & SavedTime
    End If

    If Me.OptionButton2.Value = True Then
    Set OutputWkb = Workbooks(InputWkb.Name)
    Set OutputSh = OutputWkb.Sheets.Add(after:=OutputWkb.Sheets(Sheets.Count))
    OutputSh.Name = "Consolidated" & SavedTime
    End If
    '================Confirm Header exists or not ========
    If Me.CheckBox1.Value = True Then
    Header = "Yes"
    End If

    '==============Unload the Userform====================
    Unload Me
    OutputSh.Activate
    ActiveWindow.DisplayGridlines = False


    Dim fc As Integer, fr As Integer, q As Integer
    fc = 1: fr = 1

    '=============Split the worksheet names based on comma
    PostsplitWorkSheets = Split(TotalWorkSheets, ",")
    Dim ShLastRow As Integer

    '=============Loop through all the worksheets
    For i = 0 To UBound(PostsplitWorkSheets)

    s = PostsplitWorkSheets(i)


    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
    If i = 0 Then
    q = 1
    Range(Cells(q, 1), Cells(LastRow, Lastcol)).Select
    Selection.Copy
    End If

    If i <> 0 Then
    If Header = "Yes" Then
    q = 2
    Else:
    q = 1
    End If
    Range(Cells(q, 1), Cells(LastRow, Lastcol)).Select
    Selection.Copy
    End If


    OutputSh.Activate
    If i = 0 Then
    OutputSh.Range("A1").PasteSpecial Paste:=xlPasteAll
    Else:
    Last = OutputSh.Range("A" & Rows.Count).End(xlUp).Row + 1
    OutputSh.Cells(Last, 1).PasteSpecial Paste:=xlPasteAll
    End If

    Application.CutCopyMode = False
    ShLastRow = CodingSh.Range("A" & Rows.Count).End(xlUp).Row + 1
    CodingSh.Cells(ShLastRow, 1).Value = s
    Next

    '===========Format The Output Worksheet======
    OutputSh.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

    'If output sheet in new workbook save the workbook
    If NewWorkbook = "Yes" Then
    OutputWkb.SaveAs fileName:=CodingWkb.Path & "\" & "OutputWkb_" & SavedTime & ".xlsx"
    InputWkb.Close
    End If

    OutputWkb.Save
    OutputWkb.Close

    Application.DisplayAlerts = True
    Nullifying_The_Variables
    Application.Speech.Speak ("Hi " & Application.UserName & " Consolidation Process Completed")
    MsgBox "Hi Consolidation Process Completed"
    End Sub