• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA to Search & Copy Folders and Subfolders for A Specific Worksheet in All Macro Enabled Workbooks

Jimean

New Member
Hello,

I am fairly new to writing VBA codes. I was able to write a VBA code to search through our shared directory file path (main folder) to look through all macro-enabled workbooks (.xlsm) and search for a specific worksheet in each workbook, "DRT621".

The macro then compiles all of the worksheets, "DRT621" from all of the mulitple workbooks into one workbook and then renames the worksheets according to the entities' name.

The macro works great. However, I need to make the macro search through subfolders (subdirectories) also. And, I don't know how many levels of subfolder/subdirectories are under each main folder. Below is the code and I'll attach the sample file as well.

Any help modifying this code so that it could look at many levels of subfolders would be very greatly appreciated!

Code:
Sub CopySheets1()
  Dim CurFile As String, DirLoc As String
  Dim DestWB As Workbook
  Dim ws As Object
  
  
  DirLoc = ThisWorkbook.Path & "\Test Shared Drive\"
  CurFile = Dir(DirLoc & "*.xlsm")
  
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  
  Set DestWB = ActiveWorkbook
  
  Do While CurFile <> vbNullString
  Dim OrigWB As Workbook
  Dim wsName As String
  Set OrigWB = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True)

  
  For Each ws In OrigWB.Sheets
  If ws.Name = "DRT621" Then 'Update with each respective timing difference code
  ws.Copy After:=DestWB.Sheets(1)
  End If
  Next
  
  For Each ws In DestWB.Sheets
  If Left(ws.Name, 6) <> "DRT621" Then 'Update with each respective timing difference code
  Cells.Copy
  End If
  Next
  
  ActiveSheet.Range("A1").Select
  Selection.PasteSpecial Paste:=xlPasteValues
  
  OrigWB.Close SaveChanges:=False
  CurFile = Dir
Loop

Application.DisplayAlerts = False
Application.ScreenUpdating = True
Application.EnableEvents = True

Set DestWB = Nothing
  
MsgBox "Step 1 Completed", vbInformation
  
End Sub

Sub CopyData()
Dim Dest As Range
Dim ws As Worksheet
Set Dest = Worksheets("List of BUs").Cells(2, 1)
For Each ws In ActiveWorkbook.Worksheets
If Left(ws.Name, 6) <> "DRT621" Then GoTo NextSht
Dest.Value = ws.Range("C6").Value
Set Dest = Dest.Offset(1)
NextSht:
Next ws

MsgBox "Step 2 Completed", vbInformation

End Sub

Sub RenSht()
Dim i As Long
With ActiveWorkbook
For i = 2 To Worksheets.Count - 1
Worksheets(i).Name = Worksheets(Worksheets.Count).Range("A" & i).Value
Next i
End With

MsgBox "Step 3 Completed", vbInformation


End Sub
 

Attachments

  • DBW_Test with Real Shared Location.xlsm
    393.3 KB · Views: 29
Welcome to the forum!
First, I might suggest just using this free, ready-built tool to do your task:
http://www.rondebruin.nl/win/addins/rdbmerge.htm

You could download the add-in, run it in your workbook, and the task would be done in a few clicks.

But, if you want the code yourself, here's Ron Bruin's full code, which shows how to get the subfolder names.
Main article talking about code:
http://www.rondebruin.nl/win/s3/win008.htm
Code showing how to get subfolders:
http://www.rondebruin.nl/win/winfiles/FSOMergeCode.txt

IMO, if you're new to coding, I'd go with the first link, the add-in. Much simpler.
 
Hi Luke,

Thank you so much for your quick response and the warm welcome! Let me look at the links provided and will let you know if those will work for me.
 
Okay Luke, I looked through the RDB Merge and everything looks great except that it merges all of the data into one worksheet, unless I am missing something?

I am trying to have the data that it is being pulled to get compiled into a workbook with multiple tabs. I've attached the workbook with steps 1 and 2 completed to show what I want the end result to look like. I didn't run step 3 so that I can show that all of the tabs pulled in were the "DRT621" tab. I'll post an image of the end file since the file and a zip version of it is too large to upload.

Many thanks!!
 

Attachments

  • End Result.PNG
    End Result.PNG
    73.8 KB · Views: 10
Might I suggest that you don't use multiple sheets? For analyzing data in XL, having everything in one sheet is a much better method, as it allows XL to think of your raw data as being in a single table. The Merge Tool also has the option to let you add the File name as a column in the combined data, so you can still sort/filter to the different sheets.

Or, taking a guess based on your button names, where the final goal is to re-name all the worksheets to something else, we might first gather all the data from the different workbook into a single sheet, and then split that out into multiple sheets within the same workbook.
http://www.rondebruin.nl/win/s3/win006.htm

The problem we're trying to avoid is that all your sheets being imported have the same name, and we want some way of being able to tell them apart (other than the oh-so-helpful XL method of writing xxxx1, xxx2, xxx3, etc. :p)
 
Unfortunately, I do need mulitple tabs as the project is to pull source data to support audit.

Each tab/worksheet that is being copied over contains account numbers with amounts and adjustments, any comments preparers may have input, etc.

I wrote the code to look up a specific cell that contains the entities code name (example: TESTENTITY1, TESTENTITY2, TESTENTITY3) that will rename each worksheets accordingly. Also, since each worksheet already contains this data, I will be able to tell them apart that way.

Here is another picture of what the workbook will look like after step 3.

Again, thanks so much for the quick response!
 

Attachments

  • With Step3.PNG
    With Step3.PNG
    70.7 KB · Views: 6
The "code names" come from cell "C6" from each worksheet. Step 2, copies all of these "code names" and list them in the List of BUs worksheet. Step 3 goes into that list and renames each worksheet accordingly
 
Ok, I think I've pieced something togther that will do Step 1 for you. Note that there's 2 modules of code. Lets you specify a folder, if you want subfolders, sheet name. Copies those sheets into the same workbook. Sounds like you already have working code to do the renaming, so hopefully this works.
 

Attachments

  • CompilerBook.xlsm
    29.6 KB · Views: 33
Luke, this is brilliant. Thank you! I actually was able to piece together something last night based off of the RondeBruin merge FSO code you provided me also but I like the input box for the sheet name and will use your code instead since it works through some of my other kinks. I'll paste my code below to share with you. Thank you so very much for all your help, I really appreciate it VERY MUCH!

There are three modules to this code, the first module is an exact copy paste from RDB's Basic_Code_Module:
Code:
'*************************************************************
'****This portion goes in a module named Basic_Code_Module****
'*************************************************************


Private myFiles() As String
Private Fnum As Long

Function Get_File_Names(MyPath As String, Subfolders As Boolean, _
  ExtStr As String, myReturnedFiles As Variant) As Long

  Dim Fso_Obj As Object, RootFolder As Object
  Dim SubFolderInRoot As Object, file As Object

  'Add a slash at the end if the user forget it
  If Right(MyPath, 1) <> "\" Then
  MyPath = MyPath & "\"
  End If

  'Create FileSystemObject object
  Set Fso_Obj = CreateObject("Scripting.FileSystemObject")

  Erase myFiles()
  Fnum = 0

  'Test if the folder exist and set RootFolder
  If Fso_Obj.FolderExists(MyPath) = False Then
  Exit Function
  End If
  Set RootFolder = Fso_Obj.GetFolder(MyPath)

  'Fill the array(myFiles)with the list of Excel files in the folder(s)
  'Loop through the files in the RootFolder
  For Each file In RootFolder.Files
  If LCase(file.Name) Like LCase(ExtStr) Then
  Fnum = Fnum + 1
  ReDim Preserve myFiles(1 To Fnum)
  myFiles(Fnum) = MyPath & file.Name
  End If
  Next file

  'Loop through the files in the Sub Folders if SubFolders = True
  If Subfolders Then
  Call ListFilesInSubfolders(OfFolder:=RootFolder, FileExt:=ExtStr)
  End If

  myReturnedFiles = myFiles
  Get_File_Names = Fnum
End Function


Sub ListFilesInSubfolders(OfFolder As Object, FileExt As String)
'Origenal SubFolder code from Chip Pearson
'http://www.cpearson.com/Excel/RecursionAndFSO.htm
'Changed by Ron de Bruin, 27-March-2008
  Dim SubFolder As Object
  Dim fileInSubfolder As Object

  For Each SubFolder In OfFolder.Subfolders
  ListFilesInSubfolders OfFolder:=SubFolder, FileExt:=FileExt

  For Each fileInSubfolder In SubFolder.Files
  If LCase(fileInSubfolder.Name) Like LCase(FileExt) Then
  Fnum = Fnum + 1
  ReDim Preserve myFiles(1 To Fnum)
  myFiles(Fnum) = SubFolder & "\" & fileInSubfolder.Name
  End If
  Next fileInSubfolder

  Next SubFolder
End Sub


Function RDB_Last(choice As Integer, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
  Dim lrw As Long
  Dim lcol As Integer

  Select Case choice

  Case 1:
  On Error Resume Next
  RDB_Last = rng.Find(What:="*", _
  after:=rng.Cells(1), _
  Lookat:=xlPart, _
  LookIn:=xlFormulas, _
  SearchOrder:=xlByRows, _
  SearchDirection:=xlPrevious, _
  MatchCase:=False).Row
  On Error GoTo 0

  Case 2:
  On Error Resume Next
  RDB_Last = rng.Find(What:="*", _
  after:=rng.Cells(1), _
  Lookat:=xlPart, _
  LookIn:=xlFormulas, _
  SearchOrder:=xlByColumns, _
  SearchDirection:=xlPrevious, _
  MatchCase:=False).Column
  On Error GoTo 0

  Case 3:
  On Error Resume Next
  lrw = rng.Find(What:="*", _
  after:=rng.Cells(1), _
  Lookat:=xlPart, _
  LookIn:=xlFormulas, _
  SearchOrder:=xlByRows, _
  SearchDirection:=xlPrevious, _
  MatchCase:=False).Row
  On Error GoTo 0

  On Error Resume Next
  lcol = rng.Find(What:="*", _
  after:=rng.Cells(1), _
  Lookat:=xlPart, _
  LookIn:=xlFormulas, _
  SearchOrder:=xlByColumns, _
  SearchDirection:=xlPrevious, _
  MatchCase:=False).Column
  On Error GoTo 0

  On Error Resume Next
  RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
  If Err.Number > 0 Then
  RDB_Last = rng.Cells(1).Address(False, False)
  Err.Clear
  End If
  On Error GoTo 0

  End Select
End Function

The second is from RDB also but modified with my information:
'***********************************************************
'****This portion goes in a module named Get_Sheet_Macro****
'***********************************************************


'The example below will copy the first worksheet from each file in a new workbook
'It copy as values because the PasteAsValues argument = True

'First we call the Function "Get_File_Names" to fill a array with all file names
'There are three arguments in this Function that we can change

'1) MyPath = the folder where the files are
'2) Subfolders = True if you want to include subfolders
'3) ExtStr = file extension of the files you want to merge
'  ExtStr examples are: "*.xls" , "*.csv" , "*.xlsx"
'  "*.xlsm" ,"*.xlsb" , for all Excel file formats use "*.xl*"
'  Do not change myReturnedFiles:=myFiles


'Then if there are files in the folder we call the macro "Get_Sheet"
'There are three arguments in this macro that we can change


'1) PasteAsValues = True to paste as values (recommend)
'2) SourceShName = sheet name, if "" it will use the SourceShIndex
'3) SourceShIndex = to avoid problems with different sheet names use the index (1 is the first worksheet)
'  Do not change myReturnedFiles:=myFiles


Sub RDB_Copy_Sheet()
  Dim myFiles As Variant
  Dim myCountOfFiles As Long

  myCountOfFiles = Get_File_Names( _
  MyPath:="K:\Tax Projects\Vimean\Test Shared Drive\", _
  Subfolders:=True, _
  ExtStr:="*.xlsm", _
  myReturnedFiles:=myFiles)

  If myCountOfFiles = 0 Then
  MsgBox "No files that match the ExtStr in this folder"
  Exit Sub
  End If

  Get_Sheet _
  PasteAsValues:=True, _
  SourceShName:="DRT621", _
  SourceShIndex:=1, _
  myReturnedFiles:=myFiles

End Sub



' Note: You not have to change the macro below, you only
' edit and run the RDB_Copy_Sheet above.


Sub Get_Sheet(PasteAsValues As Boolean, SourceShName As String, _
  SourceShIndex As Integer, myReturnedFiles As Variant)
  Dim mybook As Workbook, DestWB As Workbook
  Dim CalcMode As Long
  Dim SourceSh As Variant
  Dim sh As Worksheet
  Dim i As Long

  'Change ScreenUpdating, Calculation and EnableEvents
  With Application
  CalcMode = .Calculation
  .Calculation = xlCalculationManual
  .ScreenUpdating = False
  .EnableEvents = False
  .DisplayAlerts = False
  .AskToUpdateLinks = False
  End With

  On Error GoTo ExitTheSub

  'Add a new workbook with one sheet
  Set DestWB = ActiveWorkbook 'Workbooks.Add(xlWBATWorksheet).Worksheets(1)


  'Check if we use a named sheet or the index
  If SourceShName = "" Then
  SourceSh = SourceShIndex
  Else
  SourceSh = SourceShName
  End If
  
  'Loop through all files in the array(myFiles)
  For i = LBound(myReturnedFiles) To UBound(myReturnedFiles)
  Set mybook = Nothing
  On Error Resume Next
  Set mybook = Workbooks.Open(myReturnedFiles(i))
  On Error GoTo 0

  If Not mybook Is Nothing Then

  'Set sh and check if it is a valid
  On Error Resume Next
  Set sh = mybook.Sheets(SourceSh)

  If Err.Number > 0 Then
  Err.Clear
  Set sh = Nothing
  End If
  On Error GoTo 0

  If Not sh Is Nothing Then
  sh.Copy after:=DestWB.Sheets(1) ' DestWB.Parent.Sheets(DestWB.Parent.Sheets.Count)

  On Error Resume Next
  ActiveSheet.Name = mybook.Name
  On Error GoTo 0

  If PasteAsValues = True Then
  With ActiveSheet.UsedRange
  .Value = .Value
  End With
  End If

  End If
  'Close the workbook without saving
  mybook.Close savechanges:=False
  End If

  'Open the next workbook
  Next i

  ' delete the first sheet in the workbook
  Application.DisplayAlerts = False
  On Error Resume Next
  DestWB.Delete
  On Error GoTo 0
  Application.DisplayAlerts = True

ExitTheSub:
  'Restore ScreenUpdating, Calculation and EnableEvents
  With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = CalcMode
  End With
  
  MsgBox "Step 1 Completed", vbInformation
  
End Sub

And the final module does the copy sheet name and renaming:
Sub CopyData()
Dim Dest As Range
Dim ws As Worksheet
Set Dest = Worksheets("List of BUs").Cells(1, 1)
For Each ws In ActiveWorkbook.Worksheets
'If Left(ws.Name, 6) <> "DRT621" Then GoTo NextSht
Dest.Value = ws.Range("C6").Value
Set Dest = Dest.Offset(1)
NextSht:
Next ws

MsgBox "Step 2 Completed", vbInformation

End Sub

Sub RenSht()
Dim i As Long
With ActiveWorkbook
For i = 2 To Worksheets.Count - 1
Worksheets(i).Name = Worksheets(Worksheets.Count).Range("A" & i).Value
Next i
End With

MsgBox "Step 3 Completed", vbInformation


End Sub
 
Wonderful, glad we could work together to solve it, and hopefully you got to learn a bit more about coding. :) :awesome:
 
Hi Luke,

I have a follow-up question if you have some time - how would I edit the code so that it only searches for worksheets that are not hidden?

Any help would be greatly appreciated, thanks!!
 
In the Get_Sheet macro, near beginning, it does a check to confirm that sheet exists currently.
Code:
If Err.Number > 0 Then
  Err.Clear
  Set sh = Nothing
  End If
We could add a bit here to test if sheet is hidden.
Code:
If Err.Number > 0 Or sh.Visible <> xlSheetVisible Then
  Err.Clear
  Set sh = Nothing
End If

Which now says, if the worksheet doesn't exist, or it's not visible, then ignore it.
 
In testing the macro works wonders, but when I put it in the live environment, I'm running into the following error:
Run-time error '1004':
Method 'Copy' of object'_Worksheet' failed I'll attach a snapshot of the debug
 

Attachments

  • Debug.PNG
    Debug.PNG
    61.7 KB · Views: 7
Looks like the line was changed, as I can see a commented portion out to the right. Can you verify that there is a sheet named "List of BUs" in the workbook running the code?
I'd also suggest changing the object "Sheets" to be "Worksheets".
 
sh is set as worksheets, unless I'm missing something?

Code:
Option Explicit
'The example below will copy the first worksheet from each file in a new workbook
'It copy as values because the PasteAsValues argument = True

'First we call the Function "Get_File_Names" to fill a array with all file names
'There are three arguments in this Function that we can change

'1) MyPath = the folder where the files are
'2) Subfolders = True if you want to include subfolders
'3) ExtStr = file extension of the files you want to merge
'  ExtStr examples are: "*.xls" , "*.csv" , "*.xlsx"
'  "*.xlsm" ,"*.xlsb" , for all Excel file formats use "*.xl*"
'  Do not change myReturnedFiles:=myFiles


'Then if there are files in the folder we call the macro "Get_Sheet"
'There are three arguments in this macro that we can change


'1) PasteAsValues = True to paste as values (recommend)
'2) SourceShName = sheet name, if "" it will use the SourceShIndex
'3) SourceShIndex = to avoid problems with different sheet names use the index (1 is the first worksheet)
'  Do not change myReturnedFiles:=myFiles


Sub RDB_Copy_Sheet()
  Dim myFiles As Variant
  Dim myCountOfFiles As Long
  Dim oApp As Object
  Dim oFolder As Variant
  Dim shName As String
  Dim subCheck As Boolean

  Set oApp = CreateObject("Shell.Application")

  'Browse to the folder
  Set oFolder = oApp.BrowseForFolder(0, "Select folder", 512)

  If Not oFolder Is Nothing Then
'Change Subfolders = TRUE
subCheck = (MsgBox("Include subfolders?", vbYesNo + vbDefaultButton1, "Subfolders") = vbYes)
  myCountOfFiles = Get_File_Names( _
  MyPath:=oFolder.Self.Path, _
  Subfolders:=True, _
  ExtStr:="*.xlsm", _
  myReturnedFiles:=myFiles)
   
  If myCountOfFiles = 0 Then
  MsgBox "No files that match the ExtStr in this folder"
  Exit Sub
  End If
'Define which sheet name you want to look for
shName = InputBox("What is the name of sheet to look for?", "Sheet name", "DRT621")
  Get_Sheet _
  PasteAsValues:=True, _
  SourceShName:=shName, _
  SourceShIndex:=1, _
  myReturnedFiles:=myFiles

  End If

End Sub



' Note: You not have to change the macro below, you only
' edit and run the RDB_Copy_Sheet above.


Sub Get_Sheet(PasteAsValues As Boolean, SourceShName As String, _
  SourceShIndex As Integer, myReturnedFiles As Variant)
  Dim mybook As Workbook, BaseWks As Worksheet
  Dim CalcMode As Long
  Dim SourceSh As Variant
  Dim sh As Worksheet
  Dim i As Long

  'Change ScreenUpdating, Calculation and EnableEvents
  With Application
  CalcMode = .Calculation
  .Calculation = xlCalculationManual
  .ScreenUpdating = False
  .EnableEvents = False
  .DisplayAlerts = False
  End With

  On Error GoTo ExitTheSub

  'Add a new workbook with one sheet
  'Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
  'Instead, add to current workbook
  Set BaseWks = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
   
  'Check if we use a named sheet or the index
  If SourceShName = "" Then
  SourceSh = SourceShIndex
  Else
  SourceSh = SourceShName
  End If

  'Loop through all files in the array(myFiles)
  For i = LBound(myReturnedFiles) To UBound(myReturnedFiles)
  Set mybook = Nothing
  On Error Resume Next
  Set mybook = Workbooks.Open(myReturnedFiles(i))
  On Error GoTo 0

  If Not mybook Is Nothing Then

  'Set sh and check if it is a valid
  On Error Resume Next
  Set sh = mybook.Sheets(SourceSh)

  If Err.Number > 0 Or sh.Visible <> xlSheetVisible Then
  Err.Clear
  Set sh = Nothing
  End If
  On Error GoTo 0

  If Not sh Is Nothing Then
  sh.Copy before:=BaseWks.Parent.Sheets("List of BUs") '(BaseWks.Parent.Sheets.Count)

  On Error Resume Next
  ActiveSheet.Name = mybook.Name
  On Error GoTo 0

  If PasteAsValues = True Then
  With ActiveSheet.UsedRange
  .Value = .Value
  End With
  End If

  End If
  'Close the workbook without saving
  mybook.Close savechanges:=False
  End If

  'Open the next workbook
  Next i

  ' delete the first sheet in the workbook
  Application.DisplayAlerts = False
  On Error Resume Next
  BaseWks.Delete
  On Error GoTo 0
  Application.DisplayAlerts = True

ExitTheSub:
  'Restore ScreenUpdating, Calculation and EnableEvents
  With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = CalcMode
  End With
   
  MsgBox "Step 1 Completed", vbInformation
   
End Sub
 
Correct, sh is a worksheet.

Curious, I can run a small test on the code and it works fine on my end...

I would suggest running the code, and when it hits the error, leave it in debug mode. In the Immediate window of the VBE (hit Ctrl+g if not visible) copy this command, and hit enter:
?sh.Name

It should return the name of a worksheet. This lets us test that sh has been properly defined. If that works, try this command:
?BaseWks.Name

and then:
?BaseWks.Parent.Name

(side note: In the immediate window, we can query something by preceding the line with a question mark)

Let us know if any of those commands generated an error, or had a weird response.
 
Thank you for the troubleshooting options. I will try them out tomorrow and get back to you. As always, your help is very much appreciated, Luke!
 
Hello again Luke,

I ran the immediate code tests you suggested and the one that came up weird is when I typed in ?BaseWks.Name, it returned "Sheet2" which somehow got added after the last tab, "List of BUs" when I ran the macro, so I may not have properly defined this
 
Correct...earlier in that macro, you'll see this line:
Code:
 Set BaseWks = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
This is what is adding the new sheet, defined as BaseWks

If you want to just use the List of BUs sheet w/o adding a new sheet, change that line to be:
Code:
 Set BaseWks = ThisWorkbook.Worksheets("List of BUs")
 
That code fixed the adding of "Sheet 2" but I'm still running into the same runtime error 1004 :(. Very thankful for all the resolutions so far though, any other suggestions that can help with this error?
 
Is the workbook or worksheets protected by chance?

So far we've determined that the sheets in question do exist, so no error there...
Besides the 1004, what does the actual err message say?

Sorry for not having more ideas, but I'm starting to just guess here. It should work.
 
Back
Top