Copy data from various files

[VegasNath]

I am attempting to create a macro that will open all files within all subfolders of a specific folder and copy the data found from each file into one file (I guess this file will hold the macro), one below the other.

Could anyoune provide me with a starting point to get going or point me to similar code. I'm sure that once I get the basic setup, I can modify from there.

Thanks for any help available.

[HansV]

See Get Data from Saved Workbooks on the WS Lounge.

[VegasNath]

Thanks Hans, that got me started......

Code: Select all

Sub DataConsolidate()

Const strPath = "P:\Finance\"
Const strSheetName = "Untitled"

Dim wbkIn As Workbook
Dim wshIn As Worksheet
Dim wshOut As Worksheet
Dim strFile As String
Dim lngMaxInRow As Long
Dim rngLastOut As Range

Set wshOut = ActiveSheet
strFile = Dir(strPath & "AVI B04400 DUMP DETAIL.xls")

Do While Not strFile = ""
    Set wbkIn = Workbooks.Open(strPath & strFile)
    Set wshIn = wbkIn.Worksheets(strSheetName)
    lngMaxInRow = wshIn.Range("A65536").End(xlUp).Row
    
    Set rngLastOut = wshOut.Range("A65536").End(xlUp).Offset(1, 0)
    wshIn.Range("A" & lngMaxInRow & ":O2").Copy Destination:=rngLastOut
    wbkIn.Close SaveChanges:=False
    strFile = Dir
  Loop
  
End Sub

So, I have:

Const strPath = "P:\Finance\"
strFile = Dir(strPath & "DUMP DETAIL.xls")

What I need to do is loop through every strFile that are found within all subfolders of stpPath?

IOW, within strPath, there are 300+ files with the name strFile that I need to consolidate into one file.

Thanks

[HansV]

Try this (I haven't actually tested it, it's air code):

Code: Select all

Sub DataConsolidate()
  Const strPath = "P:\Finance\"
  Const strSheetName = "Untitled"
  Const strFile = "AVI B04400 DUMP DETAIL.xls"

  Dim wbkIn As Workbook
  Dim wshIn As Worksheet
  Dim wshOut As Worksheet
  Dim strSubfolder As String
  Dim lngMaxInRow As Long
  Dim rngLastOut As Range

  Set wshOut = ActiveSheet
  ' Get name of first subfolder
  strSubfolder = Dir(strPath & "*", vbDirectory)
  Do While Not strSubfolder = ""
    ' Avoid the current and parent folders . and ..
    If Not (strSubfolder = "." Or strSubfolder = "..") Then
      Set wbkIn = Workbooks.Open(strPath & strSubfolder & "\" & strFile)
      Set wshIn = wbkIn.Worksheets(strSheetName)
      lngMaxInRow = wshIn.Range("A65536").End(xlUp).Row
      Set rngLastOut = wshOut.Range("A65536").End(xlUp).Offset(1, 0)
      wshIn.Range("A" & lngMaxInRow & ":O2").Copy Destination:=rngLastOut
      wbkIn.Close SaveChanges:=False
    End If
    strFile = Dir
  Loop
End Sub

[VegasNath]

Hans, thanks for your help here.

The code seems to go into an endless loop without finding anything. I apologise if I am not providing enough information, I will attempt to clarify:

Const strPath = "P:\Finance\"

P:\Finance\sub1\sub2\sub3

There will be upto 12 folders in sub1
There will be upto 25 folders in sub2
There will be 1 folder in sub 3 containing 1 strFile

I need to get to every strFile within the set of subfolders, approx 300.

I apologise if the original information was not sufficient.

[HansV]

That's more complicated. Is this an accurate description, or just an example of the structure?

[VegasNath]

This is an exact representation of the file structure. I need to action each days file for each month within 2009 & 2010.

P:\Finance\X\Y\Z\2009\02 Feb\01.02.10\Autofiles

.......

P:\Finance\X\Y\Z\2010\01 Jan\04.01.10\Autofiles
P:\Finance\X\Y\Z\2010\01 Jan\05.01.10\Autofiles

......etc

[VegasNath]

I think it would be best if the code starts at the "year" folder, and then I adjust the code to run it for another year. For 2 reasons, I'm not certain if one year will fit to one sheet, and also I was going to run 2010 (to date) first to see how long 4 months takes to execute.

[HansV]

I'll look into it later on.

[VegasNath]

Thankyou Hans.

[HansV]

Here's an attempt. It will search ALL subfolders of the specified folder for a workbook with the specified workbook name, and it will search within each such workbook for a sheet with the specified sheet name. Copy the code into a module, adjust the constants as needed, then run the macro DoIt.

Code: Select all

Private wshOut As Worksheet

Private Const strPath = "P:\Finance\"
Private Const strFile = "AVI B04400 DUMP DETAIL.xls"
Private Const strSheetName = "Untitled"

Sub DoIt()
  Dim objFSO As Object
  Dim objFolder As Object
  Set wshOut = ActiveSheet
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFSO.GetFolder(strPath)
  Call CheckFolder(objFolder)
  Set objFSO = Nothing
End Sub

Sub CheckFolder(objFolder As Object)
  Dim objFile As Object
  Dim objSubfolder As Object
  Dim wbkIn As Workbook
  Dim wshIn As Worksheet
  Dim strFolderPath As String
  Dim lngMaxInRow As Long
  Dim rngLastOut As Range
  strFolderPath = objFolder.Path
  If Not Right(strFolderPath, 1) = "\" Then
    strFolderPath = strFolderPath & "\"
  End If
  ' Loop through files
  For Each objFile In objFolder.Files
    If objFile.Name = strFile Then
      Set wbkIn = Workbooks.Open(strFolderPath & strFile)
      For Each wshIn In wbkIn.Worksheets
        If wshIn.Name = strSheetName Then
          lngMaxInRow = wshIn.Range("A" & wshIn.Rows.Count).End(xlUp).Row
          Set rngLastOut = wshOut.Range("A" & wshOut.Rows.Count).End(xlUp).Offset(1, 0)
          wshIn.Range("A2:O" & lngMaxInRow).Copy Destination:=rngLastOut
        End If
      Next wshIn
      wbkIn.Close SaveChanges:=False
    End If
  Next objFile
  ' Loop through subfolders
  For Each objSubfolder In objFolder.SubFolders
    Call CheckFolder(objSubfolder)
  Next objSubfolder
End Sub

(In Excel 2003 you could have used the Application.FileSearch object, but since this is not supported any more in Excel 2007 and later, I used a more general approach)

[VegasNath]

Hans, you are a star!
I cannot test completely until I am back in the office tomorrow, but running a quick test on some dummy files and folders at home, it appears to do the trick superbly!
This will save a lot of work, I'm very grateful for your help! :Thankyou:

I'm sure that I will be able to modify this for many future tasks.

[VegasNath]

Very odd.....

This worked perfectly last night on my home (vista) machine, but does not work on my (xp) work machine.

I have stepped through the code and it executes fine, but does not find a strFile. I have double checked all of the "Const"'s and they are correct.

Any idea's?

[HansV]

I just now tested the code in Excel 2003 on Windows XP, and it worked correctly. Make sure that you haven't missed a space before or after a file name, etc.

[VegasNath]

I found the problem......

.xls does not work but .XLS does.

No idea why? Very odd.

Anyhow, this saved me a huge amount of work, Thankyou very much Hans!! A superb tool to add to my collection.

[HansV]

File names and extensions are not case sensitive in Windows. They are in Unix and related operating systems - are your workbooks stored on a Unix server?

[VegasNath]

File names and extensions are not case sensitive in Windows. They are in Unix and related operating systems - are your workbooks stored on a Unix server?

No, however the files are received from an external source. If they are created 'outside of windows', could that be a cause?

The .xls was definately the issue as I tried again later today, only .XLS would work.

[HansV]

Stupid of me, sorry. VBA string comparisons are case-sensitive by default. You could work around it (apart from finding out whether you should use .xls or .XLS each time) in one of the following ways:

Use

If UCase(objFile.Name) = UCase(strFile) Then

and

If UCase(wshIn.Name) = UCase(strSheetName) Then

This will compare the upper case versions of all names involved.

- or -

Insert the following line at the top of the code module:

Option Compare Text

This will make all string comparisons in the module case insensitive.

[VegasNath]

Interesting, Thanks.

I did not even think to look at any of the files to see if the extention's were .xls or .XLS. I am guessing that they must be the latter. I shall check tomorrow.

I was just so glad to get it going!

I have just tested the "Option Compare Text" which does pick up both. Great!