Console - Combine - Save - Clear

PC Central.vba

Sub Console()

    Dim FolderPath As String
    Dim Filename As String
    Dim sheet As Worksheet
    
    Application.ScreenUpdating = False
    
    FolderPath = GetFolder & "\"
    'MsgBox FolderPath
    
    Filename = Dir(FolderPath & "*.xls*")
    
    Do While Filename <> ""
        'MsgBox Filename
        Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
        For Each sheet In ActiveWorkbook.Sheets
            sheet.Copy After:=ThisWorkbook.Sheets(1)
        Next sheet
        Workbooks(Filename).Close
        Filename = Dir()
    Loop
    
    Call Combine
    
    Application.ScreenUpdating = True
End Sub

Public Sub CountWorksheet()
    MsgBox "Total number of sheets in this workbook: " & Application.Sheets.Count
End Sub

Public Sub DeleteAllExceptMe()
    Dim sheet As Worksheet
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    For Each sheet In Application.ActiveWorkbook.Worksheets
        If sheet.Name <> "Sheet1" Then
            sheet.Delete
        End If
    Next
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Sub Combine()
    Dim J As Integer
    Dim Path As String
    On Error Resume Next
    
    Application.ScreenUpdating = False
    
    Sheets(1).Select
    Worksheets.Add After:=Worksheets(1)
    Sheets(2).Name = "Combined"
    
    For J = 2 To Sheets.Count
        Sheets(J).Activate
        Range("A1").Select
        Selection.CurrentRegion.Select
        Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
        Selection.Copy Destination:=Sheets("Combined").Range("A65536").End(xlUp)(2)
    Next
    
    Sheets("Combined").Activate
    
    Application.ScreenUpdating = True
    
End Sub


Function GetFolder()
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With

NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

Function GetFile()
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFilePicker)
    With fldr
        .Title = "Select a File"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With

NextCode:
    GetFile = sItem
    Set fldr = Nothing
End Function

Sub SaveNewFile()
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
TryAgain:
    Flname = InputBox("Enter File Name :", "Creating New File...")
   
    If Flname <> "" Then
        Set NewWkbk = Workbooks.Add
        
        For J = 2 To ThisWorkbook.Sheets.Count
            ThisWorkbook.Sheets(J).Copy Before:=NewWkbk.Sheets(J - 1)
        Next
            
        NewWkbk.SaveAs ThisWorkbook.Path & "\" & Flname
        If Err.Number = 1004 Then
            NewWkbk.Close
            MsgBox "File Name Not Valid" & vbCrLf & vbCrLf & "Try Again."
            GoTo TryAgain
        End If
        ActiveWorkbook.Close
    End If
End Sub