copy cell from multiple worksheets saved in multiple sub-folders

Hi,

I'm a total beginner with VBA and have only been able to develop the code attached through research alone and not through my own knowledge.

I'm after some help as I'm stuck for a solution; I want to enter a code in a master workbook that can search for excel workbooks through multiple sub-folders contained within a folder, and then copy a particular cell from every workbook found and paste the value into the master workbook.

The code below works fine (copies and pastes cell D9 from the workbooks found into the master workbook), however it only searches through the sub-folder named ("TA1 BASEMENT"). I want a code that starts searching from the folder "Guardrails & Gratings" onwards.

Can anyone help me with this? Any help would be much appreciated!!

--------------------------------------------------- CODE SO FAR -------------------------------
Sub Copy_Paste()

Dim MyFolder As String
Dim MyFile As String
Dim NewR As Range

MyFolder = "Y:\Syseng\Conventional Systems\Civil Systems\Ladder & Handrails Inspections 2013\Guardrails & Gratings\Schedule 8 Turb Hall\Basement\TA1 BASEMENT"
MyFile = Dir(MyFolder & "\*.xlsx")

Do While MyFile <> ""
' open the source workbook and select the source sheet
Workbooks.Open Filename:=MyFolder & "\" & MyFile
Sheets("0609188").Select
' copy the source range
Sheets("0609188").Range("D9").Select
Selection.Copy
' select current workbook and paste the values starting at B2
Windows("Master File - A.xlsm").Activate
Sheets("Sheet1").Select
Set NewR = ActiveSheet.Range("B" & ActiveSheet.Cells.Rows.Count).End(xlUp).Offset(1, 0)
NewR.PasteSpecial xlPasteValues
ActiveWorkbook.Save
MyFile = Dir
Loop

' This sub will close all workbooks except the workbook in which the code is located.
Dim WkbkName As Object
On Error GoTo Close_Error
Application.ScreenUpdating = False
For Each WkbkName In Application.Workbooks()
If WkbkName.Name <> ThisWorkbook.Name Then WkbkName.Close
Next
' If everything runs all right, exit the sub.
Exit Sub
' Error handler.
Close_Error:
MsgBox Str(Err) & " " & Error()
Resume Next

End Sub

Goggling this indicates it to be a common "problem" for people.
Your routine only searches through the sub-folder named "TA1 BASEMENT" because that is exactly what it is being asked to do.

This link, although dealing with Access, provides some VBA adapted by well known expert that will be of interest.
http://www.ammara.com/access_image_faq/recursive_folder_search.html

Hi,

I should have explained myself a bit better; I understand the code as it is will not search through the subfolder, only through the folder its being asked to. I was however hoping that there may be a simple way to adapt what I currently have so that it searches the subfolders.

I've tried adapting it using the information provided in the link but I'm having no luck, as I said I am completely new to this!!

I there anyone able to help me with this?!

Thanks!

gwyn_123, hi

Your original post indicates you can do what you want with each file, you just can't find them. The function I linked to does this nicely. Try this.

Open a new Excel workbook. Alt-F11 to get to the VBA environment. Insert a module. Copy and paste the 2 functions from the provided linked page to this module.

Now the example on the page needs put into a sub with the folder you want to start at and the file type you want to deal with. Paste this sub into the same module and run it. It will display the name of every file you will be dealing with.



Hope this is of some assistance.
NoS

Hi NoS,

I think I've done what you suggested (see code below) but nothing seems to happen. I get no error messages but I get no output either!

Please excuse me if I'm missing something really obvious!

Thanks,
Gwyn

-------------------------------------------------------------------------------
Public Function RecursiveDir(colFiles As Collection, _
strFolder As String, _
strFileSpec As String, _
bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function
Sub Find_all_Files()
Dim colFiles As New Collection
Dim vFile As Variant

RecursiveDir colFiles, "Y:\Syseng\Conventional Systems\Civil Systems\Ladder & Handrails Inspections 2013\Guardrails & Gratings", "*.xlsx", True
For Each vFile In colFiles
' open the source workbook and select the source sheet
Sheets("0609188").Select
' copy the source range
Sheets("0609188").Range("D9").Select
Selection.Copy
' select current workbook and paste the values starting at B2
Windows("Master File - B.xlsm").Activate
Sheets("Sheet1").Select
Set NewR = ActiveSheet.Range("B" & ActiveSheet.Cells.Rows.Count).End(xlUp).Offset(1, 0)
NewR.PasteSpecial xlPasteValues
ActiveWorkbook.Save
'Ctrl+g brings up the Immediate Window where you can see the file names printed out
Debug.Print vFile
Next vFile

End Sub

Hello Gwyn,

The way things work with this function is that the function compiles a collection of all the file names as specified that are contained in the folder and sub folders. You then need to create your own sub routine to deal with those files. In the previous example sub, the For Each portion steps through the file names one at a time, it is only looking at the file name not "inside" the file. The part you are missing is opening each file to get the info you're after as the For Each cycles through the collection of file names.

Try this sub. I've used a different sub name to distinguish between them.



Create a break point at the For Each line and then use F8 to step through and see what is actually going on. If/when you are satisfied with things uncomment the enable.events and screenupdating to speed things up.

Good luck
NoS

Hi NoS,

Thanks for all your help so far! Nearly there now, just one slight issue and I have no idea why this happens:

In the code below, when it is asked to copy cell D9 / cell (9, 4) it only copies and pastes from the last file it searches through. However when I experimented and changed the macro to cpoy cell I4 / cell (4, 9) it worked perfectly and copied and pasted from all files in all sub-folders.

Why would it do this? If it helps, cell D9 will always be of a different value but cell I4 is always constant i.e. will always contain the text "Location:". Is the code dependant on the files having the same value?

Nearly there, it would be massively appreciated if you could help me with this final problem!

Many thanks,
gwyn_123

---------------------------------------------------------------------------------------------------------------------------------------------
Public Function RecursiveDir(colFiles As Collection, _
strFolder As String, _
strFileSpec As String, _
bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function
Sub Collect_Info()
Dim colFiles As New Collection
Dim vFile As Variant

RecursiveDir colFiles, "Y:\Syseng\Conventional Systems\Civil Systems\Ladder & Guardrails Inspections 2013\Guardrails & Gratings", "*.xlsx", True

Application.EnableEvents = False 'turn off events
Application.ScreenUpdating = False 'turn off screen updating
For Each vFile In colFiles

'open the current vFile workbook
Workbooks.Open (vFile)
'select the sheet in vFile to retrieve info from
'Sheets("0609188").Range("D9").Select
Sheets("0609188").Select
With ActiveSheet
.Cells(9, 4).Select
Selection.Copy
End With

'come back to this workbook
Windows("Master File - B.xlsm").Activate
'find the first available row in col B on sheet 1
Sheets("Sheet1").Select
With ActiveSheet
Cells(.Cells(.Rows.Count, "B").End(xlUp).Row + 1, 2).Select
'paste copied selection here
ActiveSheet.Paste
'just to move cursor to a neutal location
Cells(1, 1).Select
End With

'go back to vFile and close it
'need file name without the path
Windows(Dir(vFile)).Activate
Application.CutCopyMode = False
ActiveWorkbook.Close

Next vFile
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

it only copies and pastes from the last file it searches through

Click to expand...

That doesn't make sense. The routine does exactly the same thing every time for every file.

I'd trouble shoot it by putting a break point at the line right after the line you have in red. This will stop execution of the routine at this point every time through and allow you to look at the workbooks currently open to see what has actually been selected. Then use F5 to continue one line at a time and keep looking to see what actually is or isn't happening.

Out of curiosity, how many files are you extracting information from in your subfolders?

Hi NoS,

Problem solved, I changed the code to paste the value only and not the cell format.

I’m very happy with how the code currently works but it would be improved if I could make the following change. Currently when I run the macro it pastes the copied values in the next available cell in the desired column (OK so far). But when I re-run the macro it pastes the values as a continuation of the previous values; is there any way to paste the values starting from the same cell (i.e. the next available cell presuming the macro had not yet been run) however many times the macro is run i.e. overwrites the previously pasted values.

Many thanks,
gwyn_123

--------------------------------------

Public Function RecursiveDir(colFiles As Collection, _
strFolder As String, _
strFileSpec As String, _
bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function
Sub PlatformID()
Dim colFiles As New Collection
Dim vFile As Variant
Dim NewR As Range

RecursiveDir colFiles, "Y:\Syseng\Conventional Systems\Civil Systems\Ladder & Guardrails Inspections 2013\Guardrails & Gratings", "*.xlsx", True

Application.EnableEvents = False 'turn off events
Application.ScreenUpdating = False 'turn off screen updating
For Each vFile In colFiles

'open the current vFile workbook
Workbooks.Open (vFile)
'select the sheet in vFile to retrieve info from
'Sheets("0609188").Range("D9").Select
Sheets("0609188").Select
With ActiveSheet
.Cells(5, 10).Select
Selection.Copy
End With

'come back to this workbook
Windows("Master - Guardrails & Gratings.xlsm").Activate
'find the first available row in col B on sheet 1
Sheets("Sheet1").Select
With ActiveSheet
Set NewR = ActiveSheet.Range("B" & ActiveSheet.Cells.Rows.Count).End(xlUp).Offset(1, 0)
'paste copied selection here
NewR.PasteSpecial xlPasteValues
'just to move cursor to a neutal location
Cells(1, 1).Select
End With

'go back to vFile and close it
'need file name without the path
Windows(Dir(vFile)).Activate
Application.CutCopyMode = False
ActiveWorkbook.Close

Next vFile
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Sure Gwyn you can do that.

In the For Each loop, you currently use NewR for the next available row to paste to every time through the loop.
You will need to change that so you specify the cell to paste to the first time through the loop and then increment row offset for additional loops.

Be aware that deleting, adding or changing location of files you are reading info from will mean that the info is not necessarily written into the same cell.

Good luck with your project
NoS

Hi NoS,

I hope this will be the last time I bother you!

Can you tell me how to do this? I can't seem to get it to overwrite the values already pasted when I re-run the macro.

Thanks,
gwyn_123

Gwyn, you only need to add/change a couple of things.

Add a variable to increment each time the procedure loops and make sure it is equal to the first row used in "B"
You need to know this ahead of time and put it in ahead of the For Each loop

Dim i as Integer
i = number of the first row used

Inside the loop change your NewR
NewR = ActiveSheet.Range("B" & i)

and just before going to the next vFile, increment i with
i = i + 1

Hope that works for you
NoS

Hi NoS,

I know it's been a while but this project has become a priority again - can you tell me how to change the For Each loop (shown below) so that the macro pastes into cell B22, no matter how many times the macro is run. Currently the macro pastes the values in the next available cell i.e. if I have already run the macro and I re-run it, then I want the 2nd set of pasted values to overwrite the original set of pasted values.

Hope this is clear! Any help would be appreciated!

Thanks,
gwyn_123

-----------------------------------------------

For Each vFile In colFiles

'open the current vFile workbook
Workbooks.Open (vFile)
'select the sheet in vFile to retrieve info from
'Sheets("0609188").Range("D9").Select
Sheets("0609188").Select
With ActiveSheet
.Cells(6, 10).Select
Selection.Copy
End With

'come back to this workbook
Windows("Copy of Master - Ladders.xlsm").Activate
'find the first available row in col B on sheet 1
Sheets("Sheet1").Select
With ActiveSheet
Set NewR = ActiveSheet.Range("B" & ActiveSheet.Cells.Rows.Count).End(xlUp).Offset(1, 0)
'paste copied selection here
NewR.PasteSpecial xlPasteValues
'just to move cursor to a neutal location
Cells(1, 1).Select
End With

'go back to vFile and close it
'need file name without the path
Windows(Dir(vFile)).Activate
Application.CutCopyMode = False
ActiveWorkbook.Close

Next vFile

gwyn_123,

What you are asking will result in the value from "J6" from sheet 0609188 in the last workbook the loop opens being the value in "B22" of sheet1 in your Copy of Master - Ladders.xlsm when the macro finishes.

This leads me to ask why cycle through all the files in a folder and its sub-folders?

If that really is what you want, change

Set NewR = ActiveSheet.Range("B" & ActiveSheet.Cells.Rows.Count).End(xlUp).Offset(1, 0)
to
Set NewR = ActiveSheet.Range("B22")

If that's not what you want, post your workbooks so we can see what you're actually dealing with.

Good Luck with your project
NoS