Run a VBA macro on all files in a folder

T

td_excelforum

New Member
Joined
Dec 3, 2021
Messages
6
Office Version
  1. 365
Platform
  1. Windows
Hi!

I'm phasing a problem were my macro that works for a single excel workbook needs to be able to work for all workbooks in a folder. The macro does multiple things: 1) opens and saves all sheets in a workbook to specific location 2) Extracts title from a graph to T99 if graph exists 3) removes all rows before any column contains a keywords ("datum"). It works very well but I have 100s of workbooks that I want to run this macro on.

Here is the original macro:

VBA Code: 
Sub b2()

Dim wbThis As Workbook
Dim wbNew As Workbook
Dim ws As Worksheet
Dim strFilename As String
Dim fRg As Range


    Set wbThis = ThisWorkbook
    For Each ws In wbThis.Worksheets
        strFilename = wbThis.Path & "/singlesheets/" & ws.Name
        ws.Copy
        Set wbNew = ActiveWorkbook
        On Error Resume Next
            Sheets(1).ChartObjects(1).Activate
    
            If Err.Number <> 0 Then
            Else
                Worksheets(1).Range("T99").Value = Worksheets(1).ChartObjects("Chart 1").Chart.ChartTitle.Text
            End If
        Set fRg = Cells.Find(What:="datum", LookAt:=xlWhole)
     
        If Not fRg Is Nothing Then
            If fRg.Row <> 1 Then
                    Range("A1", fRg.Offset(-1)).EntireRow.Delete
            Else
            End If
        Else
        End If
        wbNew.SaveAs strFilename
        wbNew.Close
    Next ws

End Sub


and here is my non-functioning module that repeatedly conducts the above macro on the same workbook but does not continue to the next workbook within the folder:

VBA Code: 
Sub LoopThroughFiles()

    Dim xFd As FileDialog
    Dim xFdItem As Variant
    Dim xFileName As String
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    If xFd.Show = -1 Then
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
        xFileName = Dir(xFdItem & "*.xls*")
        Do While xFileName <> ""
            With Workbooks.Open(xFdItem & xFileName)
                'your code here
Dim wbThis As Workbook
Dim wbNew As Workbook
Dim ws As Worksheet
Dim strFilename As String
Dim fRg As Range


    Set wbThis = ThisWorkbook
    For Each ws In wbThis.Worksheets
        strFilename = wbThis.Path & "/singlesheets/" & ws.Name
        ws.Copy
        Set wbNew = ActiveWorkbook
        On Error Resume Next
            Sheets(1).ChartObjects(1).Activate
    
            If Err.Number <> 0 Then
            Else
                Worksheets(1).Range("T99").Value = Worksheets(1).ChartObjects("Chart 1").Chart.ChartTitle.Text
            End If
        Set fRg = Cells.Find(What:="datum", LookAt:=xlWhole)
     
        If Not fRg Is Nothing Then
            If fRg.Row <> 1 Then
                    Range("A1", fRg.Offset(-1)).EntireRow.Delete
            Else
            End If
        Else
        End If
        wbNew.SaveAs strFilename
        wbNew.Close
    Next ws
            End With
            xFileName = Dir
        Loop
    End If
    
End Sub


I hope you can help me save some time ;)
 

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
Sort by date Sort by votes
Hi and welcome to MrExcel.

Consider the following:
1. The new files will be saved in the folder where you have the book with the macro, but in the subfolder "singlesheets".
2. If you have multiple files, but in different books you can have the name of the same sheet, that is, in multiple books you can have the sheet "Sheet1", then I added a function to name the book as sheet1-1, sheet1-2 , sheet1-3 and so on.

Try this:

VBA Code: 
Sub b3()
  Dim wb As Workbook, wbNew As Workbook
  Dim ws As Worksheet
  Dim strFilename As String, sPath As String
  Dim fRg As Range
  
  Dim xFd As FileDialog
  Dim xFdItem As Variant
  Dim xFileName As String
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  sPath = ThisWorkbook.Path & "/singlesheets/"
  Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
  If xFd.Show <> -1 Then Exit Sub
  
  xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
  xFileName = Dir(xFdItem & "*.xls*")
  Do While xFileName <> ""
  
    Set wb = Workbooks.Open(xFdItem & xFileName)
    For Each ws In wb.Sheets
    
      strFilename = NewName(sPath, ws.Name, "xlsx")
      ws.Copy
      Set wbNew = ActiveWorkbook
      On Error Resume Next
      Sheets(1).ChartObjects(1).Activate
      If Err.Number <> 0 Then
      Else
        Sheets(1).Range("T99").Value = Sheets(1).ChartObjects("Chart 1").Chart.ChartTitle.Text
      End If
      Set fRg = Cells.Find(What:="datum", LookAt:=xlWhole)
      If Not fRg Is Nothing Then
        If fRg.Row <> 1 Then Range("A1", fRg.Offset(-1)).EntireRow.Delete
      End If
      wbNew.SaveAs strFilename
      wbNew.Close
      
    Next ws
    
    xFileName = Dir()
    
  Loop
End Sub
 
Upvote 0
DanteAmor said:
Hi and welcome to MrExcel.

Consider the following:
1. The new files will be saved in the folder where you have the book with the macro, but in the subfolder "singlesheets".
2. If you have multiple files, but in different books you can have the name of the same sheet, that is, in multiple books you can have the sheet "Sheet1", then I added a function to name the book as sheet1-1, sheet1-2 , sheet1-3 and so on.

Try this:

VBA Code: 
Sub b3()
  Dim wb As Workbook, wbNew As Workbook
  Dim ws As Worksheet
  Dim strFilename As String, sPath As String
  Dim fRg As Range
 
  Dim xFd As FileDialog
  Dim xFdItem As Variant
  Dim xFileName As String
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  sPath = ThisWorkbook.Path & "/singlesheets/"
  Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
  If xFd.Show <> -1 Then Exit Sub
 
  xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
  xFileName = Dir(xFdItem & "*.xls*")
  Do While xFileName <> ""
 
    Set wb = Workbooks.Open(xFdItem & xFileName)
    For Each ws In wb.Sheets
   
      strFilename = NewName(sPath, ws.Name, "xlsx")
      ws.Copy
      Set wbNew = ActiveWorkbook
      On Error Resume Next
      Sheets(1).ChartObjects(1).Activate
      If Err.Number <> 0 Then
      Else
        Sheets(1).Range("T99").Value = Sheets(1).ChartObjects("Chart 1").Chart.ChartTitle.Text
      End If
      Set fRg = Cells.Find(What:="datum", LookAt:=xlWhole)
      If Not fRg Is Nothing Then
        If fRg.Row <> 1 Then Range("A1", fRg.Offset(-1)).EntireRow.Delete
      End If
      wbNew.SaveAs strFilename
      wbNew.Close
     
    Next ws
   
    xFileName = Dir()
   
  Loop
End Sub
Click to expand...
Thanks alot DaneArmor, only one detail that is causing the Compilation error/Subject/function not defined. I marks the line:
VBA Code: 
strFilename = [B]NewName[/B](sPath, ws.Name, "xlsx")

I can't find this function reference either? Or am I doing something else wrong?

Best
 
Upvote 0
I forgot the function.
1638673534111.png


Here the complete code.

VBA Code: 
Sub b3()
  Dim wb As Workbook, wbNew As Workbook
  Dim ws As Worksheet
  Dim strFilename As String, sPath As String
  Dim fRg As Range
  
  Dim xFd As FileDialog
  Dim xFdItem As Variant
  Dim xFileName As String
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  sPath = ThisWorkbook.Path & "/singlesheets/"
  Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
  If xFd.Show <> -1 Then Exit Sub
  
  xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
  xFileName = Dir(xFdItem & "*.xls*")
  Do While xFileName <> ""
  
    Set wb = Workbooks.Open(xFdItem & xFileName)
    For Each ws In wb.Sheets
    
      strFilename = NewName(sPath, ws.Name, "xlsx")
      ws.Copy
      Set wbNew = ActiveWorkbook
      On Error Resume Next
      Sheets(1).ChartObjects(1).Activate
      If Err.Number <> 0 Then
      Else
        Sheets(1).Range("T99").Value = Sheets(1).ChartObjects("Chart 1").Chart.ChartTitle.Text
      End If
      Set fRg = Cells.Find(What:="datum", LookAt:=xlWhole)
      If Not fRg Is Nothing Then
        If fRg.Row <> 1 Then Range("A1", fRg.Offset(-1)).EntireRow.Delete
      End If
      wbNew.SaveAs strFilename
      wbNew.Close
      
    Next ws
    
    xFileName = Dir()
    
  Loop
End Sub

Function NewName(sPath As String, wsName As String, ext As String) As String
  Dim temp As String
  Dim n As Long
  temp = sPath & wsName & "." & ext
  Do While True
    If Dir(temp) = "" Then
      Exit Do
    End If
    n = n + 1
    temp = sPath & wsName & "-" & n & "." & ext
  Loop
  NewName = temp
End Function
 
Upvote 0
DanteAmor said:
I forgot the function. View attachment 52697

Here the complete code.

VBA Code: 
Sub b3()
  Dim wb As Workbook, wbNew As Workbook
  Dim ws As Worksheet
  Dim strFilename As String, sPath As String
  Dim fRg As Range
 
  Dim xFd As FileDialog
  Dim xFdItem As Variant
  Dim xFileName As String
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  sPath = ThisWorkbook.Path & "/singlesheets/"
  Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
  If xFd.Show <> -1 Then Exit Sub
 
  xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
  xFileName = Dir(xFdItem & "*.xls*")
  Do While xFileName <> ""
 
    Set wb = Workbooks.Open(xFdItem & xFileName)
    For Each ws In wb.Sheets
   
      strFilename = NewName(sPath, ws.Name, "xlsx")
      ws.Copy
      Set wbNew = ActiveWorkbook
      On Error Resume Next
      Sheets(1).ChartObjects(1).Activate
      If Err.Number <> 0 Then
      Else
        Sheets(1).Range("T99").Value = Sheets(1).ChartObjects("Chart 1").Chart.ChartTitle.Text
      End If
      Set fRg = Cells.Find(What:="datum", LookAt:=xlWhole)
      If Not fRg Is Nothing Then
        If fRg.Row <> 1 Then Range("A1", fRg.Offset(-1)).EntireRow.Delete
      End If
      wbNew.SaveAs strFilename
      wbNew.Close
     
    Next ws
   
    xFileName = Dir()
   
  Loop
End Sub

Function NewName(sPath As String, wsName As String, ext As String) As String
  Dim temp As String
  Dim n As Long
  temp = sPath & wsName & "." & ext
  Do While True
    If Dir(temp) = "" Then
      Exit Do
    End If
    n = n + 1
    temp = sPath & wsName & "-" & n & "." & ext
  Loop
  NewName = temp
End Function
Click to expand...
Thanks again for the quick answer - but somehow no files are saved, the macro "runs" through all files in the folder but does not save the sheets after process in the /singlesheets" folder.
 
Upvote 0
DanteAmor said:
1. The new files will be saved in the folder where you have the book with the macro, but in the subfolder "singlesheets".
Click to expand...

Go through the macro step by step by pressing F8 and check in which folder you are saving the file, by forwarding the variable strFilename
Or
After this line:
VBA Code: 
wbNew.SaveAs strFilename

add this line:
VBA Code: 
msgbox "Folder: " & strFilename
 
Upvote 0
DanteAmor said:
Go through the macro step by step by pressing F8 and check in which folder you are saving the file, by forwarding the variable strFilename
Or
After this line:
VBA Code: 
wbNew.SaveAs strFilename

add this line:
VBA Code: 
msgbox "Folder: " & strFilename
Click to expand...
Ok, so the macro runs from \Users\myname\AppData\Roaming\Excel\XLSTART and not the current-path of the the selected workbook dir. There is no singlesheets folder there so the files are not saved anywhere.
 
Upvote 0
DanteAmor said:
Consider the following:
1. The new files will be saved in the folder where you have the book with the macro, but in the subfolder "singlesheets".
Click to expand...
As I mentioned from the beginning.
In the folder where you have the macro, create a subfolder called "singlesheets" and run the macro again.
Or put the file with the macro in a folder, whatever you want, but inside there should be a subfolder with the name "singlesheets" and try again.
 
Upvote 0
Excellent, it works! However, something in the loop in the newname function is funny as it's looping a random amount of times for each sheet gemerating name, name-1, name-2 etc with the same content 50- 100x per sheet
 
Upvote 0
You must log in or register to reply here.

Similar threads

countryfan_nt
  • Solved
Copy Header to all the headers of the workbooks in a specific folder.
Replies
2
Views
427
countryfan_nt
countryfan_nt
Guna13
  • Question Question
How to Efficient way for create Multiple Workbooks
Replies
1
Views
402
Guna13
Guna13
I
  • Question Question
Unable to run VBA code
Replies
6
Views
165
RoryA
RoryA
H
  • Question Question
VBA split file based and send splitted file in separate emails
Replies
0
Views
735
harmless92
H
H
  • Question Question
Macro to Open File and limit selection where files contains "Parts" in C
Replies
4
Views
270
howard
H

Forum statistics

Threads
1,224,824
Messages
6,181,186
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

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