Copy and Past the Data from Multiple Closed Workbooks

[thespardian]

Hi there!
I am seeking help on the following matter: -

I have multiple workbooks, with 05 worksheets, in folder “NewFolder” on the desktop.
The format of Sheets is same in all workbooks.
I after a VBA code which would do the following tasks in a separate workbook called Summery.xlsm

Task 1
Copy all data of Sheet D from Workbook1->and paste it to Sheet1of Summery
Copy all data of Sheet D from Workbook 2->and paste it to Sheet1of Summery
Copy all data of Sheet D from Workbook 3->and paste it to Sheet1of Summery
And so on till last workbook

Task2
Copy all data of Sheet A from Workbook1->and paste it to Sheet2of Summery
Copy all data of Sheet A from Workbook2->and paste it to Sheet2of Summery
Copy all data of Sheet A from Workbook3->and paste it to Sheet2of Summery
And so on till last workbook

Any help on the matter will be highly appreciated.

Links of the workbooks are given below, please
Summery
Book1
Book2

 

[eiloken]

try this, i think this will work:

Sub MergeData()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim fso As Object, fi As Object, fo As Object
    Dim foPath As String
    Dim wb As Workbook, ws As Worksheet
    Dim i As Long, j As Long
    Set folder = Application.FileDialog(msoFileDialogFolderPicker) 'choose target folder
    If folder.Show <> -1 Then Exit Sub
    foPath = folder.SelectedItems(1)
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fo = fso.GetFolder(foPath)
    For Each fi In fo.Files
        If fso.GetExtensioNname(fi) Like "xls*" Then 'Loop through files in folder and find excel file
            Set wb = Workbooks.Open(fso.GetAbsolutePathName(fi))
            For Each ws In wb.Sheets 'loop through sheet in workbook and find sheet A and sheet D
                If ws.Name = "A" Then
                    If Not IsEmpty(ws.Range("B3")) Then
                        ws.Range("A3:O" & lr(ws, 1)).Copy Destination:=ThisWorkbook.Sheets(2).Range("A" & lr(ThisWorkbook.Sheets(2), 1) + 1)
                    End If
                ElseIf ws.Name = "D" Then
                    If Not IsEmpty(ws.Range("A6")) Or Not IsEmpty("J6") Then
                        If lr(ws, 2) > lr(ws, 10) Then
                            i = lr(ws, 2)
                        Else
                            i = lr(ws, 10)
                        End If
                        If lr(ws, 1) > lr(ws, 9) Then
                            j = lr(ws, 1)
                        Else
                            j = lr(ws, 9)
                        End If
                        ws.Range("B6:Q" & i).Copy Destination:=ThisWorkbook.Sheets(1).Range("A" & j + 1)
                    End If
                End If
            Next ws
            wb.Close (False)
        End If
    Next fi
    MsgBox "Completed"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Private Function lr(ByVal ws As Worksheet, ByVal col As Integer) As Long
    lr = ws.Cells(Rows.Count, col).End(xlUp).Row
End Function

 

[thespardian]

Thanks for your input, I not familiar with VB Code. i copied your code and paste it in the Module of workbook named summery. But I am facing following error. Please help me on the following error.

 

[eiloken]

Thanks for your input, I not familiar with VB Code. i copied your code and paste it in the Module of workbook named summery. But I am facing following error. Please help me on the following error.

show me dialog of error, oh, i see that your orginal summery workbook has 1 sheet, in that case, you should add sheet 2

 

[thespardian]

show me dialog of error, oh, i see that your orginal summery workbook has 1 sheet, in that case, you should add sheet 2

I have added the sheet2 before runing your codes. I noticed that when i run the code. It ask me to select the folder. I select the folder but it doesn't show me the excel files. Please see the picture below:-

 

[eiloken]

I have added the sheet2. I noticed that when i run the code. It ask me to select the folder. I select the folder but it doesn't show me the excel files. Please see the picture below:-

in this code you don't need to select file, just select folder that include your files

 

[thespardian]

Sorry for my dumb follow up question. I copied your code and paste it in the workbook named summery. Then i selected the Book1 and Book2. Then i came to workbook Summery and run the macro. Am i doing right?
I have already added the sheet2 in summery

 

[eiloken]

Sorry for my dumb follow up question. I copied your code and paste it in the workbook named summery. Then i selected the Book1 and Book2. Then i came to workbook Summery and run the macro. Am i doing right?
I have already added the sheet2 in summery

no, you just need to paste code to your summery workbook and make sure it have 2 sheet or more, then run "MergeData" macro and select folder that included all your workbooks that need to get data from and press OK and wait still done. oh and i has some mistake in code that will find wrong lastrow in sheet 2 of Summery workbook so please change "MergeData" like this:

Sub MergeData()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim fso As Object, fi As Object, fo As Object
    Dim foPath As String
    Dim wb As Workbook, ws As Worksheet
    Dim i As Long, j As Long
    Set folder = Application.FileDialog(msoFileDialogFolderPicker) 'choose target folder
    If folder.Show <> -1 Then Exit Sub
    foPath = folder.SelectedItems(1)
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fo = fso.GetFolder(foPath)
    For Each fi In fo.Files
        If fso.GetExtensioNname(fi) Like "xls*" Then 'Loop through files in folder and find excel file
            Set wb = Workbooks.Open(fso.GetAbsolutePathName(fi))
            For Each ws In wb.Sheets 'loop through sheet in workbook and find sheet A and sheet D
                If ws.Name = "A" Then
                    If Not IsEmpty(ws.Range("B3")) Then
                        ws.Range("A3:O" & lr(ws, 1)).Copy Destination:=ThisWorkbook.Sheets(2).Range("A" & lr(ThisWorkbook.Sheets(2), 1) + 1)
                    End If
                ElseIf ws.Name = "D" Then
                    If Not IsEmpty(ws.Range("A6")) Or Not IsEmpty("J6") Then
                        If lr(ws, 2) > lr(ws, 10) Then
                            i = lr(ws, 2)
                        Else
                            i = lr(ws, 10)
                        End If
                        If lr(ThisWorkbook.Sheets(2), 1) > lr(ThisWorkbook.Sheets(1), 9) Then
                            j = lr(ThisWorkbook.Sheets(1), 1)
                        Else
                            j = lr(ThisWorkbook.Sheets(1), 9)
                        End If
                        ws.Range("B6:Q" & i).Copy Destination:=ThisWorkbook.Sheets(1).Range("A" & j + 1)
                    End If
                End If
            Next ws
            wb.Close (False)
        End If
    Next fi
    MsgBox "Completed"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

i ran this with your files and it worked.

 

[thespardian]

I followed your instructions. The codes doesn't show any error. But nothing happened. Just a blank workbook opened. The picture of which is as under

 

[thespardian]

here is the link for the folder. May be i doing something wrong and couldn't fix it myself.
NewFolder