Consolidate multiple sheets into a different workbook

[ajoshi76]

Hello

I am attaching the workbooks in question. They have multiple sheets each. The sheet name are same in each workbook.

I would like to consolidate all sheet by sheet in one workbook.

So all Milestone sheet data should consolidate in Milestone sheet of new workbook and so on.

Request you to please help on the macro.

Thanks
Ashish

 

[Nebu]

Hi:

Why do you need a macro for this Can't you do it linking it to a access DB.

Thanks

 

[Deepak]

Check this...

Option Explicit
Sub Get_Data_v1()
Dim mywb As Workbook, openWB As Workbook
Dim fol As String, sPath As String, sFil As String, strName As String
Dim ws As Worksheet

Application.ScreenUpdating = False
Application.EnableEvents = False
     
With ThisWorkbook
    fol = Application.ThisWorkbook.Path
    sPath = fol & "\" 'Application.ThisWorkbook.Path & "\"
    sFil = Dir(sPath & "*.xlsx")
       
    If sFil = "" Then MsgBox "No File found!!!", vbCritical: Exit Sub
           
    Do While sFil <> ""
        strName = sPath & sFil
        Set openWB = Workbooks.Open(strName, False, True)
            For Each ws In openWB.Sheets
                ws.Range("A1").CurrentRegion.Offset(1).Copy
                    With .Sheets(ws.Name)
                        .Range("A" & .Range("A1").CurrentRegion.Rows.Count + 1).PasteSpecial xlPasteFormats
                        .Range("A" & .Range("A1").CurrentRegion.Rows.Count + 1).PasteSpecial xlPasteValues
                    End With
            Next
        openWB.Close 0
        sFil = Dir
    Loop
   
End With
    Set openWB = Nothing

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

 

[Deepak]

Hi,

I did some modification to make it dynamic.

Option Explicit
Sub Get_Data_v2()
Dim mywb As Workbook, openWB As Workbook
Dim fol As String, sPath As String, sFil As String, strName As String
Dim ws As Worksheet, lrow As Integer
Dim SheetExist As Boolean

Application.ScreenUpdating = False
Application.EnableEvents = False
     
With ThisWorkbook
    fol = Application.ThisWorkbook.Path
    sPath = fol & "\"
    sFil = Dir(sPath & "*.xlsx")
       
    If sFil = "" Then MsgBox "No File found!!!", vbCritical: Exit Sub
           
    Do While sFil <> ""
        strName = sPath & sFil
        Set openWB = Workbooks.Open(strName, False, True)
            For Each ws In openWB.Sheets
           
            SheetExist = False
            On Error Resume Next
            SheetExist = CBool(Len(.Sheets.Item(ws.Name).Name))
            On Error GoTo 0
           
                If Not SheetExist Then
                    .Sheets.Add().Name = ws.Name
                        ws.Range("A1").CurrentRegion.Copy
                Else
                        ws.Range("A1").CurrentRegion.Offset(1).Copy
                End If
                       
                    With .Sheets(ws.Name)
                        lrow = Application.CountA(.Columns(1)) + 1
                        .Range("A" & lrow).PasteSpecial xlPasteFormats
                        .Range("A" & lrow).PasteSpecial xlPasteValues
                    End With
            Next
        openWB.Close 0
        sFil = Dir
    Loop
   
End With
    Set openWB = Nothing

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub