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.

 

[Logit]

Look at the following for a start :

Macro to open multiple workbooks and copy a range of data based on todays date. Then paste the data in master workbook in one sheet under each other.

 

[AbhishekJain]

Look at the following for a start :

Macro to open multiple workbooks and copy a range of data based on todays date. Then paste the data in master workbook in one sheet under each other.

Thanks for the response, the below code is working for me... but needs one quick fix, it should do paste special as the original file contains some formulas. Any help apreciated

 

[AbhishekJain]

Thanks for the response, the below code is working for me... but needs one quick fix, it should do paste special as the original file contains some formulas. Any help apreciated

Sub Copy_Sheets_To_Master()

Application.ScreenUpdating = False

Dim flder As FileDialog, FileName As String, FileChosen As Integer, wkbSource As Workbook, wsDest As Worksheet, ws As Worksheet, lRow As Long

Set wsDest = ThisWorkbook.Sheets("Master")

Set flder = Application.FileDialog(msoFileDialogFilePicker)

flder.Title = "Please Select a folder and file."

FileChosen = flder.Show

FileName = flder.SelectedItems(1)

Set wkbSource = Workbooks.Open(FileName)

For Each ws In Sheets(Array("Services Art. 61 LTVA"))

With ws

lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

.Cells(2, 1).Resize(lRow - 1, 15).Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)

End With

Next ws

Application.ScreenUpdating = True

End Sub

 

[AbhishekJain]

Sub Copy_Sheets_To_Master()

Application.ScreenUpdating = False

Dim flder As FileDialog, FileName As String, FileChosen As Integer, wkbSource As Workbook, wsDest As Worksheet, ws As Worksheet, lRow As Long

Set wsDest = ThisWorkbook.Sheets("Master")

Set flder = Application.FileDialog(msoFileDialogFilePicker)

flder.Title = "Please Select a folder and file."

FileChosen = flder.Show

FileName = flder.SelectedItems(1)

Set wkbSource = Workbooks.Open(FileName)

For Each ws In Sheets(Array("Services Art. 61 LTVA"))

With ws

lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

.Cells(2, 1).Resize(lRow - 1, 15).Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)

End With

Next ws

Application.ScreenUpdating = True

End Sub

Hello, Could anyone help me in tweaking this code, so I can get the result as paste special. Thank you

 

[Fuji]

Different method. (read the data from closed workbook via formula)

Sub test()
    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

 

[AbhishekJain]

Different method. (read the data from closed workbook via formula)

Sub test()
    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

Thank 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

 

[Fuji]

It is a folder picker, not the file picker.
If you select the folder in which all the files reside, it runs...

 

[AbhishekJain]

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

 

[AbhishekJain]

It is a folder picker, not the file picker.
If you select the folder in which all the files reside, it runs...

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