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]

you are very quick, actually I edited my post to the above

hank you for getting back, its working, I am able to see the data in text formats, but it stopped in between at ( .[v1].FormulaArray = "=max(if('" & myDir & "[" & fn & "]" & wsName & "'!a1:r50000<>"""",row(1:50000)))" and getting the following error message.. not able to fix this

Hope I will be able to get the data in the same format but as pastespecial (without the formulas) at the end

 

[AbhishekJain]

hank you for getting back, its working, I am able to see the data in text formats, but it stopped in between at ( .[v1].FormulaArray = "=max(if('" & myDir & "[" & fn & "]" & wsName & "'!a1:r50000<>"""",row(1:50000)))" and getting the following error message.. not able to fix this

Hope I will be able to get the data in the same format but as pastespecial (without the formulas) at the end

It worked once, but not anymore its stopping at this point-

 

[Fuji]

I've tested with xl2010 & ms365 and both working fine.

And never encountered such issue on that line.

Is it stopping without error?
If so, can you just reboot the PC?

 

[AbhishekJain]

I restarted my machine, and yes, its still stopping without an error after " If .Show Then "
When I browse and choose a path it stops there, if I try to run it again starts from beginning

 

[AbhishekJain]

My machine forced to restart once more with some updates, Now its running flawlessly until here, then I get this error.
If I skipp this step, I am getting one more error

After this all my excel files are getting closed

 

[Fuji]

The code is working fine though...

Try this one then...

Sub test()
    Dim myDir$, fn$, wsName$, wb As Workbook, n$, s$
    wsName = "Sheet1"
    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
    Set wb = Workbooks.Add(xlWBATWorksheet)
    With wb.Sheets(1)
        Do While fn <> ""
            .Range("v1").FormulaArray = "=max(if('" & myDir & "[" & fn & "]" & wsName & "'!a1:r50000<>"""",row(1:50000)))"
            n = .Range("v1").Value: .Range("v1").Value = ""
            If n > 0 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]

Correction

    Dim myDir$, fn$, wsName$, wb As Workbook, n$, s$

should be

    Dim myDir$, fn$, wsName$, wb As Workbook, n&, s$

And this is actually open each workbook.

Sub test2()
    Dim myDir$, fn$, wsName$, wb As Workbook, n&
    wsName = "Sheet1"
    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
    Set wb = Workbooks.Add(xlWBATWorksheet)
    With wb.Sheets(1)
        Do While fn <> ""
            If fn <> ThisWorkbook.Name Then
                With Workbooks.Open(myDir & fn)
                    With .Sheets(wsName)
                        n = .Evaluate("max(if(a1:r50000<>"""",row(1:50000)))")
                        .Range("a12:r" & n).Copy
                        wb.Sheets(1).Range("a" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
                    End With
                    Application.CutCopyMode = False
                    .Close
                End With
            End If
            fn = Dir
        Loop
        .Parent.SaveAs myDir & "MyResult", 51
    End With
    Application.ScreenUpdating = True
End Sub

 

[AbhishekJain]

You are genius! Thank you so much, its working fine now

 

[AbhishekJain]

Sorry for coming back on the same topic!

I was using the below code, until now.. But after working on a few files, I understand that sometimes, we also have data in two other tabs. So is it possible to copy the contents from multiple tabs and get the result in a separate tabs like we have in the original workbook and have the same tab name as in original? I can define the tab name as well if needed.

In short, there are 12 workbooks, having "TabA, TabB, and TabC" copy the contents from each tab from each workbook and create separate a separate excel workbook with 3 different tabs TabA, TabB and TabC and in the same format as in the original.

 

[Fuji]

Which one are you using, test or test2?
How do you want the sheet name when duplicate sheet name found?