Code for copying data from multiple workbooks

[AbhishekJain]

Dear All,

Thanks for allowing me to rejoin the group..I am in need for codes which can copy the data from multiple workbooks to a new workbook. Each workbooks having different number of rows and has sub headings and subtotals in between.. but there are few common things as well, all worksheet data starts from row 12 i.e cell A12:R12 and all have same tab names. Is there a way I can put this in VBA coding?
Thankyou in advance for your help.

 

[AbhishekJain]

Hello!
I am using the below one.

On sheet name; each workbook has 7 sheets, I am looking to copy only 3 sheets (they have unique names). So I would be okay if it copies the same sheet name as I have on the original workbook, or it can even leave it as Sheet1, Sheet2 and Sheet3.


Sub ClickHere()
Dim myDir$, fn$, wsName$, wb As Workbook, n$, s$
wsName = "Sheet1" '<--- change to actual sheet name in common.
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myDir = .SelectedItems(1) & "\"
End With
If myDir = "" Then Exit Sub
fn = Dir(myDir & "*.xls*")
If fn = "" Then Exit Sub
Application.ScreenUpdating = False
Set wb = Workbooks.Add(xlWBATWorksheet)
With wb.Sheets(1)
Do While fn <> ""
.[v1].FormulaArray = "=max(if('" & myDir & "[" & fn & "]" & wsName & "'!a1:r50000<>"""",row(1:50000)))"
n = .[v1]: .[v1] = ""
If n Then
.Range("a" & Rows.Count).End(xlUp)(3) = fn
s = "'" & myDir & "[" & fn & "]" & wsName & "'!a12"
With .Range("a" & Rows.Count).End(xlUp)(2).Resize(n, 18)
.Formula = "=if(" & s & "<>""""," & s & ","""")"
.Value = .Value
End With
End If
fn = Dir
Loop
.SaveAs myDir & "MyResult", 51
End With
Application.ScreenUpdating = True
End Sub

 

[Fuji]

try

Sub test()
    Dim myDir$, fn$, wb As Workbook, i&, n$, s$, myList, e, myWS As Worksheet
    myList = Array("sheet1", "sheet2", "sheet3")  '<--- change to correct sheet names and you can add/remove.
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = "" Then Exit Sub
    fn = Dir(myDir & "*.xls*")
    If fn = "" Then Exit Sub
    Application.ScreenUpdating = False
    On Error Resume Next
    Kill myDir & "\myresult.xlsx"
    On Error GoTo 0
    n = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = UBound(myList) + 1
    Set wb = Workbooks.Add
    Application.SheetsInNewWorkbook = n
    Set myWS = ThisWorkbook.Sheets(1)
    For i = 0 To UBound(myList)
        wb.Sheets(i + 1).Name = myList(i)
    Next
    Do While fn <> ""
        For Each e In myList
            myWS.Range("v1").FormulaArray = "=max(if('" & myDir & "[" & fn & "]" & e & "'!a1:r50000<>"""",row(1:50000)))"
            n = myWS.Range("v1").Value: myWS.Range("v1").Value = ""
            If n > 0 Then
                wb.Sheets(e).Range("a" & Rows.Count).End(xlUp)(3) = fn
                s = "'" & myDir & "[" & fn & "]" & e & "'!a12"
                With wb.Sheets(e).Range("a" & Rows.Count).End(xlUp)(2).Resize(n, 18)
                    .Formula = "=if(" & s & "<>""""," & s & ","""")"
                    .Value = .Value
                End With
            End If
        Next
        fn = Dir
    Loop
    wb.SaveAs myDir & "MyResult", 51
    Application.ScreenUpdating = True
End Sub

 

[AbhishekJain]

Thanks, its working perfectly. One last request, is it possible to get the result in the same format as in the original workbook (the fonts/coloring)?
If you need to write a completely new one, then I am okay to use this one

 

[Fuji]

Code in #17, test2 is actually opens each workbook and copy the range.
The code is using PasteSpecial with paste values, so formats will be removed.

If there are many files, it runs slow...

Sub test2()
    Dim myDir$, fn$, wsName$, wb As Workbook, i&, n&, myList, e
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = "" Then Exit Sub
    fn = Dir(myDir & "*.xls*")
    If fn = "" Then Exit Sub
    Application.ScreenUpdating = False
    On Error Resume Next
    Kill myDir & "\myresult.xlsx"
    On Error GoTo 0
    myList = Array("sheet1", "sheet2", "sheet3")
    n = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = UBound(myList) + 1
    Set wb = Workbooks.Add
    Application.SheetsInNewWorkbook = n
    For i = 0 To UBound(myList)
        wb.Sheets(i + 1).Name = myList(i)
    Next
    Do While fn <> ""
        If fn <> ThisWorkbook.Name Then
            With Workbooks.Open(myDir & fn)
                For Each e In myList
                    With .Sheets(e)
                        n = .Evaluate("max(if(a1:r50000<>"""",row(1:50000)))")
                        .Range("a12:r" & n).Copy wb.Sheets(e).Range("a" & Rows.Count).End(xlUp)(2)
                    End With
                Next
                Application.CutCopyMode = False
                .Close
            End With
        End If
        fn = Dir
    Loop
    wb.SaveAs myDir & "MyResult", 51
    Application.ScreenUpdating = True
End Sub

 

[AbhishekJain]

Thank you very much..
I will stick with the previous one