Copy Data from several workbooks in same folder containing "Debtors"

howard

Well-known Member
Joined
Jun 26, 2006
Messages
6,561
Office Version
  1. 2021
Platform
  1. Windows
I have attempted to write code to copy data from sheets(3) (this is a Pivot Table) in Columns A:F called from all workbooks containing "South End Debtors.xlsm, Conti Debtors.xlsm etc" in folder C:\Debtors


When runig the macro, I do not get any eeror messages, but no data is being copied into sheet1 in the destination workbook containing the macro


It would be appreciated if someone could kindly assist me


Code:
 Sub Open_Spec_Files()
    
    Dim objFSO       As Object
    Dim objMyFolder  As Object
    Dim objMyFile    As Object
    Dim wbMyWorkBook As Workbook
    Dim lngLastRow   As Long
    
    Application.ScreenUpdating = False
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objMyFolder = objFSO.GetFolder("C:\Debtors")
   
    For Each objMyFile In objMyFolder.Files
        
        If objFSO.GetExtensionName(objMyFile) = "xlsm" And StrConv(Left(objFSO.GetBaseName(objMyFile), 7), vbUpperCase) = "Debtors" Then
            '...set the wbMyWorkBook variable by opening the workbook and copy the data from range A4:O[lngLastRow].
            Set wbMyWorkBook = Workbooks.Open(objMyFolder & "\" & objMyFile.Name)
            
            On Error Resume Next
                lngLastRow = wbMyWorkBook.Sheets(3).Range("A:F").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            On Error GoTo 0
            If lngLastRow >= 4 Then
                With wbMyWorkBook
                    .Sheets(1).Range("A4:F" & lngLastRow).Copy Destination:=ThisWorkbook.ActiveSheet.Range("A2")
                    .Close SaveChanges:=False
                End With
            End If
        End If
    Next objMyFile
   Set objFSO = Nothing
    Set objMyFolder = Nothing
    
    Application.ScreenUpdating = True

End Sub
 
Last edited:

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
Change
Code:
ThisWorkbook.ActiveSheet
to reference the actual sheet then report back where you are after stepping through the code with F8 and checking that the range is copying (i.e that you are getting the marching ants around the range).

Also when you do get it to copy then you are going to overwrite the data in the destination on each loop as it is going to copy to A2 every time.
 
Last edited:
Upvote 0
Thanks for the help

I have amended the code. I stepped through the code and do not get the marching ants around the range. Some of the rows are hidden as I did not want to display zeroes in Col E in the
source data


I also need the data to copy in the destination workbook after the last row in sheet1 containing data

Line amended
Code:
   .Sheets(3).Range("A3:F" & lngLastRow).Copy Destination:=ThisWorkbook.Sheets(1).Range("A2").Offset(, 1)


Code:
 Sub Open_Spec_Files()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Dim objFSO       As Object
    Dim objMyFolder  As Object
    Dim objMyFile    As Object
    Dim wbMyWorkBook As Workbook
    Dim lngLastRow   As Long
    
    Application.ScreenUpdating = False
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objMyFolder = objFSO.GetFolder("C:\Debtors")
   
    For Each objMyFile In objMyFolder.Files
        
        If objFSO.GetExtensionName(objMyFile) = "xlsm" And StrConv(Right(objFSO.GetBaseName(objMyFile), 7), vbProperCase) = "Debtors" Then
            '...set the wbMyWorkBook variable by opening the workbook and copy the data from range A4:O[lngLastRow].
            Set wbMyWorkBook = Workbooks.Open(objMyFolder & "\" & objMyFile.Name)
            
            On Error Resume Next
                lngLastRow = wbMyWorkBook.Sheets(1).Range("A:F").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
           ' On Error GoTo 0
            If lngLastRow >= 3 Then
                With wbMyWorkBook
                    .Sheets(3).Range("A3:F" & lngLastRow).Copy Destination:=ThisWorkbook.Sheets(1).Range("A2").Offset(, 1)
                    .Close SaveChanges:=False
                End With
            End If
        End If
    Next objMyFile
   Set objFSO = Nothing
    Set objMyFolder = Nothing
    
    Application.ScreenUpdating = True
Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0
Step through the code below, it is just your code with bits commented out and On Error Goto 0 uncommented (why did you comment it?) and the destination removed.

Do you get the marching ants and does it ever reach the copy line when stepping through with F8?

Also why does your lngLastRow reference sheets(1) but your copy range is on sheets(3)?

Code:
 [color=darkblue]Sub[/color] Open_Spec_Files()
[color=green]'    Application.DisplayAlerts = False[/color]
[color=green]'    Application.ScreenUpdating = False[/color]
    [color=darkblue]Dim[/color] objFSO       [color=darkblue]As[/color] [color=darkblue]Object[/color]
    [color=darkblue]Dim[/color] objMyFolder  [color=darkblue]As[/color] [color=darkblue]Object[/color]
    [color=darkblue]Dim[/color] objMyFile    [color=darkblue]As[/color] [color=darkblue]Object[/color]
    [color=darkblue]Dim[/color] wbMyWorkBook [color=darkblue]As[/color] Workbook
    [color=darkblue]Dim[/color] lngLastRow   [color=darkblue]As[/color] [color=darkblue]Long[/color]
    
[color=green]'    Application.ScreenUpdating = False[/color]
    
    [color=darkblue]Set[/color] objFSO = CreateObject("Scripting.FileSystemObject")
    [color=darkblue]Set[/color] objMyFolder = objFSO.GetFolder("C:\Debtors")
   
    [color=darkblue]For[/color] [color=darkblue]Each[/color] objMyFile [color=darkblue]In[/color] objMyFolder.Files
        
        [color=darkblue]If[/color] objFSO.GetExtensionName(objMyFile) = "xlsm" And StrConv(Right(objFSO.GetBaseName(objMyFile), 7), vbProperCase) = "Debtors" [color=darkblue]Then[/color]
            [color=green]'...set the wbMyWorkBook variable by opening the workbook and copy the data from range A4:O[lngLastRow].[/color]
            [color=darkblue]Set[/color] wbMyWorkBook = Workbooks.Open(objMyFolder & "\" & objMyFile.Name)
            
            [color=darkblue]On[/color] [color=darkblue]Error[/color] [color=darkblue]Resume[/color] [color=darkblue]Next[/color]
                lngLastRow = wbMyWorkBook.Sheets(1).Range("A:F").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            [color=darkblue]On[/color] [color=darkblue]Error[/color] [color=darkblue]GoTo[/color] 0
            [color=darkblue]If[/color] lngLastRow >= 3 [color=darkblue]Then[/color]
                [color=darkblue]With[/color] wbMyWorkBook
                    .Sheets(3).Range("A3:F" & lngLastRow).Copy
                [color=darkblue]End[/color] [color=darkblue]With[/color]
            [color=darkblue]End[/color] [color=darkblue]If[/color]
        [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=darkblue]Next[/color] objMyFile
   [color=darkblue]Set[/color] objFSO = [color=darkblue]Nothing[/color]
    [color=darkblue]Set[/color] objMyFolder = [color=darkblue]Nothing[/color]
    
    Application.ScreenUpdating = [color=darkblue]True[/color]
Application.DisplayAlerts = [color=darkblue]True[/color]
    Application.ScreenUpdating = [color=darkblue]True[/color]
[color=darkblue]End[/color] [color=darkblue]Sub[/color]
 
Last edited:
Upvote 0
Thanks for the help Mark

1) On error Go to 0 ws inadvertenently commented
2) lngLastRow reference sheets(1) should have been sheets(3)


When stepping through F8 I get Marching Ants on one of the source workbooks

I get running time error 1004 '~ Excel cannot open the file Br1 Dept1 Debtors.xlsm' because the file format or file extension is not valid


It would be apprecited if you could kindly assist me
 
Last edited:
Upvote 0
When stepping through F8 I get Marching Ants on one of the source workbooks

Then (assuming that ThisWorkbook is the correct workbook)

Code:
    With wbMyWorkBook
        .Sheets(3).Range("A3:F" & lngLastRow).Copy _
                Destination:=ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp)(2)
        .Close SaveChanges:=False
    End With

I get running time error 1004 '~ Excel cannot open the file Br1 Dept1 Debtors.xlsm' because the file format or file extension is not valid

Can you open the file manually?
 
Upvote 0
Thanks for all your help & patience

The Data is now being copied

I would like one small change. I need the data to paste value the data as I have a column in the Pivot Tables (Col F) that contains formulas

I have tried to amend it, but cannot get it right


Code:
 Sheets(3).Range("A3:F" & lngLastRow).Copy _
                Destination:=ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp)(2).pastevalues xlvalues
 
Upvote 0
Code:
Sheets(3).Range("A3:F" & lngLastRow).Copy
ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
Application.CutCopyMode = False
 
Upvote 0
Thanks for the help

The data is pasted from sheet(3) to sheet(1), but I now get runm time error autotomation error anf the following code is highlighted


Code:
.Sheets(3).Range("A3:F" & lngLastRow).Copy

Kindly amend and advise
 
Upvote 0
Kindly amend and advise
Nothing I can amend and advise on.

Check what the workbook is when the error occurs as you will probably find it is to do with the workbook in your loop.
 
Upvote 0

Forum statistics

Threads
1,213,501
Messages
6,114,010
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top