asked on

Copy data from closed workbooks

I need to copy data from 18 different workbooks. Each workbook will be in the same folder. Each workbook will have a different name but there will only be these 18 files in the folder although more could be added in the future but the same rules will apply. Each workbook will have over 20 sheets and I need to copy data from 14 of them, daily.

So my question is, Can an expert provide me with vba code that will:

Copy data from each file and insert the data inot my active workbook without opening the 18 closed workbooks

The range is the same in all 14 sheets in every one of the workbooks. [A7:S?] (so if the are 3 tems A7;S9, 50 items A7:S56 etc)

in my active workbook the range is the same, so the data would be copied into [Say Sheet1] cell A7. Data from each of the other 17 workbooks would be added to the next blank cell in column A each time.

so Copy A7:S9 from first workbook into Active workbook cell A7 [3 items] then Copy A7:S56 from second workbook into Active workbook cell A10 [50 items]

Thanksin advance

Subodh Tiwari (Neeraj)

Please try the following code and see if it does what you are trying to achieve.

Preparation:

1) Reference Required: Microsoft Scripting Runtime

2) Make sure to change the Source Folder Path in the code as per requirement.

Sub CopyDataFromWorkbooks()
Dim Swb As Workbook, Dwb As Workbook
Dim ws As Worksheet, Dws As Worksheet
Dim fso As Scripting.FileSystemObject
Dim fil As Scripting.File
Dim sFolderPath As String
Dim SourceFolder As Scripting.Folder
Dim Dlr As Long, Slr As Long, cnt As Long

Application.ScreenUpdating = False

sFolderPath = "C:\Jagwarman\My Files"   'Source Folder Path
Set Dwb = ThisWorkbook
Set Dws = Dwb.Sheets("Sheet1")             'Destination Sheet on the Master Workbook where data will be copied

Dlr = Dws.Cells(Rows.Count, 1).End(xlUp).Row
If Dlr > 6 Then Dws.Range("A7:S" & Dlr).Clear

Set fso = New Scripting.FileSystemObject

If Not fso.FolderExists(sFolderPath) Then
    MsgBox "Source Folder does not exists."
    Exit Sub
End If

Set SourceFolder = fso.GetFolder(sFolderPath)

For Each fil In SourceFolder.Files
    DoEvents
    If Left(fso.GetExtensionName(fil.Path), 2) = "xl" And fil.Name <> Dwb.Name Then
        Application.StatusBar = "Processing file " & fil.Name & " of folder " & sFolderPath & "."
        Workbooks.Open fil.Path
        Set Swb = ActiveWorkbook
        For Each ws In Swb.Worksheets
            Slr = ws.Cells(Rows.Count, 1).End(xlUp).Row
            cnt = cnt + 1
            If Slr > 6 And cnt <= 14 Then
                Dlr = Dws.Cells(Rows.Count, 1).End(xlUp).Row + 1
                If Dlr <= 6 Then Dlr = 7
                ws.Range("A7:S" & Slr).Copy Dws.Range("A" & Dlr)
                Application.CutCopyMode = 0
            End If
        Next ws
    End If
    cnt = 0
    Swb.Close False
Next fil
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox "Task Complete.", vbInformation
End Sub

Open in new window

Jagwarman

ASKER

I am getting 'User Defined type not defined' at Dim fso As Scripting.FileSystemObject

I added "Microsoft DAO 3.0 Object Library" but still get the error

Subodh Tiwari (Neeraj)

You didn't read my reply carefully, its written in the bold that you need to add the reference to the Microsoft Scripting Runtime.

Jagwarman

ASKER

I did read it but do not understand as I am not a VBA expert

Subodh Tiwari (Neeraj)

To add the reference to the Microsoft Scripting Runtime Library, follow these steps....

Press Alt + F11 to open VBA Editor --> Tools --> References --> Find Microsoft Scripting Runtime from the list below --> Check the box next to Microsoft Scripting Runtime --> OK

That's it.

Let me know if you are still having any issue with this.

Jagwarman

ASKER

sorry for being dumb.

Now I get

Swb.Close False

Object variable or with block Variable not set

ASKER CERTIFIED SOLUTION

Subodh Tiwari (Neeraj)

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Jagwarman

ASKER

Hi sktneer

I need to give it a good test but in the meantime, I note it is copying with all the existing formulas, is it possible to change this so that it 'pastes Values only'

Thanks for your help with this.

Subodh Tiwari (Neeraj)

To paste the values only, change this line of code

ws.Range("A7:S" & Slr).Copy Dws.Range("A" & Dlr)

Open in new window

With this line of code.

ws.Range("A7:S" & Slr).Copy
Dws.Range("A" & Dlr).PasteSpecial xlPasteValues

Open in new window

Jagwarman

ASKER

sktneer, sorry forgot I had some days off coming up. Back now so will be back on the testing today.

Subodh Tiwari (Neeraj)

Sure...

Jagwarman

ASKER

sktneer,

I have performed all sorts of tests on this to make sure it does what I need and unless I have missed any..........This is brilliant. It does exactly what I need it to. You are one 'Super Expert' Many thanks.

Jagwarman

ASKER

If I could give more than 500 points I would.

Subodh Tiwari (Neeraj)

You're welcome Jagwarman! Glad I could help.
And thanks for your kind words. Very much appreciated. :)