macro to consolidate multiple files

[aryanaveen]

Hi All,

Please help me with below,

I need a macro which will consolidate data from all files from all sheets from a particular folder.

 

[Derek73]

Already One that will load all sheets from workbooks in a folder. The other Macro will combine them into 1 sheet if that's what you need (that does assume they're all formatted the same).

Sub CombineXLSfiles()
'Asks for file folder to load from
'Loads .xls* files to new workbook into new sheets.
'skips blank sheets
Dim intChoice As Integer, shtCount As Integer
Dim LastSheet As Integer, FileCount As Integer
Dim Path As String, ThisWB As String
    FileCount = 0
    shtCount = 0
    Workbooks.Add
    ThisWB = ActiveWorkbook.Name
    For Each ws In Workbooks(ThisWB).Sheets
        shtCount = shtCount + 1
    Next
    LastSheet = shtCount
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = "Choose a folder to load Excel Files From:"
        .InitialFileName = Environ("USERPROFILE") & "\Desktop"
        intChoice = .Show
        If intChoice <> 0 Then
            Path = .SelectedItems(1)
            Else
            Exit Sub
        End If
    End With
    
    Filename = Dir(Path & "\*.xls*")
    Do While Filename <> ""
        FileCount = FileCount + 1
        Workbooks.Open Filename:=Path & "\" & Filename, ReadOnly:=True
        For Each sht In ActiveWorkbook.Sheets
            If WorksheetFunction.CountA(Cells) <> 0 Then
                sht.Copy After:=Workbooks(ThisWB).Sheets(LastSheet)
                LastSheet = LastSheet + 1
            End If
        Next
        Workbooks(Filename).Close
        Filename = Dir()
    Loop


    If FileCount = 0 Then
       MsgBox ("No .xls* Files Found!")
       Else
        Application.DisplayAlerts = False
        For wst = 1 To shtCount
            Workbooks(ThisWB).Sheets("Sheet" & wst).Delete
        Next
        MsgBox ("Loaded " & FileCount & " Files, with " & (LastSheet - shtCount) & " sheets.")
        Application.DisplayAlerts = True
    End If
End Sub




Sub CombineSheets()
'Combines all worksheets in workbook into single sheet.
'Sheets need same format (Columns same, header same) or will look loopy
'Asks how many rows in header (label rows). 


Dim J As Integer, Ret_Type As Integer, x As Integer
Dim InputHeaders As Variant
Dim HeaderRows As Integer


    InputHeaders = InputBox("Column A cannot be blank. Data must be all the way to the left of the sheets. " & _
        "Sheets must have same headers (same layout). How many rows at the top are labels?", "Header Rows, Enter an Integer:", 1)
    If Not IsNumeric(InputHeaders) Then
            MsgBox ("You either hit cancel or didn't enter a number.")
            Exit Sub
        Else
            HeaderRows = CInt(Round(InputHeaders, 0))
            If CStr(HeaderRows) <> InputHeaders Then
                Ret_Type = MsgBox("Cute. Round it to " & HeaderRows & "?", vbOKCancel, "Not an Integer.")
                If Ret_Type = 2 Then Exit Sub
            End If
            If HeaderRows > 10 Then
            Ret_Type = MsgBox("Do you really have " & HeaderRows & " rows that are labels?", vbYesNoCancel + vbQuestion, "Really? Seems unrealistic.")
                Select Case Ret_Type
                    Case 6 'Yes
                         ' No Action
                    Case 7 'No
                        Exit Sub
                    Case 2 'Cancel
                        Exit Sub
                End Select
            End If
    End If


    On Error Resume Next
    Sheets(1).Select
    Worksheets.Add
    Sheets(2).Activate
    x = 1
    Do While x <= HeaderRows
        Sheets(2).Range("A" & x).EntireRow.Select
        Selection.Copy Destination:=Sheets(1).Range("A" & x)
        x = x + 1
    Loop
    For J = 2 To Sheets.Count
    Sheets(J).Activate
        Range("A1").Select
        Selection.CurrentRegion.Select
        Selection.Offset(HeaderRows, 0).Resize(Selection.Rows.Count - HeaderRows).Select
        Selection.Copy Destination:=Sheets(1).Range("A1048576").End(xlUp)(2)
    Next
    Sheets(1).Activate
    Ret_Type = MsgBox(Sheets(1).Name & " is your combined sheet. Delete the other sheets?", vbOKCancel, "Result:")
    If Ret_Type = 2 Then Exit Sub
    Application.DisplayAlerts = False
    Do While Sheets.Count > 1
        Sheets(2).Delete
    Loop
    Application.DisplayAlerts = True


End Sub

 

[aryanaveen]

thank you , this is what I was looking for

 

[aryanaveen]

Hi Derek,

can you also provide me a code which will delete entire previous column.

For ex - If I copy and paste some data anywhere in E then entire previous row should be deleted automatically