HV_L

New Member
Joined
Dec 4, 2009
Messages
43
Hi,
I have a bunch of workbooks, now I want a extra sheet copied in all my existing workbooks.
Is that possible via VBA?:confused::confused:

Appreciate the help..;)
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
See if this gets you started. It copies "Sheet1" in the active workbook to all .xlsx files in the specified folder, as the last sheet in each workbook.

Code:
Public Sub Copy_Sheet_To_Workbooks_In_Folder()

    Dim copySheet As Worksheet
    Dim folderPath As String, fileName As String
    Dim destWorkbook As Workbook
    
    Set copySheet = ActiveWorkbook.Worksheets("Sheet1")   'change sheet name or number
    
    folderPath = "C:\path\to\folder\"   'change this

    folderPath = Trim(folderPath)
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    Application.ScreenUpdating = False
    
    fileName = Dir(folderPath & "*.xlsx")
    While fileName <> vbNullString
        Set destWorkbook = Workbooks.Open(folderPath & fileName)
        copySheet.Copy After:=destWorkbook.Worksheets(destWorkbook.Worksheets.Count)
        destWorkbook.Close saveChanges:=True
        fileName = Dir
    Wend
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"
    
End Sub
 
Upvote 0
Yes, it should be possible to include subfolders. How many levels of subfolder are there below the specified folder and how many levels do you want to include?
 
Upvote 0
I have one main folder, then there are about 250 subfolders, and each of these subfolders need to go three or four levels down
 
Upvote 0
Try this macro, which does the same as the previous macro, but for *.xlsx files in all subfolders and all levels from the main folder.

Code:
Public Sub Copy_Sheet_To_Workbooks_In_Subfolders()

    Dim copySheet As Worksheet
    Dim mainFolderPath As String
    Dim destWorkbook As Workbook
    Dim files As Variant
    Dim i As Long
    
    Set copySheet = ActiveWorkbook.Worksheets("Sheet1")   'change sheet name or number
    
    mainFolderPath = "C:\path\to\main folder\"   'change this
    
    mainFolderPath = Trim(mainFolderPath)
    If Right(mainFolderPath, 1) <> "\" Then mainFolderPath = mainFolderPath & "\"
    
    files = Split(CreateObject("WScript.Shell").Exec("cmd /c DIR " & """" & mainFolderPath & "*.xlsx" & """" & " /B /S").StdOut.ReadAll, vbCrLf)
        
    Application.ScreenUpdating = False
    
    For i = 0 To UBound(files) - 1
        Set destWorkbook = Workbooks.Open(files(i))
        copySheet.Copy After:=destWorkbook.Worksheets(destWorkbook.Worksheets.Count)
        destWorkbook.Close saveChanges:=True
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"
    
End Sub
 
Upvote 0
Try this macro, which does the same as the previous macro, but for *.xlsx files in all subfolders and all levels from the main folder.

Code:
Public Sub Copy_Sheet_To_Workbooks_In_Subfolders()

    Dim copySheet As Worksheet
    Dim mainFolderPath As String
    Dim destWorkbook As Workbook
    Dim files As Variant
    Dim i As Long
    
    Set copySheet = ActiveWorkbook.Worksheets("Sheet1")   'change sheet name or number
    
    mainFolderPath = "C:\path\to\main folder\"   'change this
    
    mainFolderPath = Trim(mainFolderPath)
    If Right(mainFolderPath, 1) <> "\" Then mainFolderPath = mainFolderPath & "\"
    
    files = Split(CreateObject("WScript.Shell").Exec("cmd /c DIR " & """" & mainFolderPath & "*.xlsx" & """" & " /B /S").StdOut.ReadAll, vbCrLf)
        
    Application.ScreenUpdating = False
    
    For i = 0 To UBound(files) - 1
        Set destWorkbook = Workbooks.Open(files(i))
        copySheet.Copy After:=destWorkbook.Worksheets(destWorkbook.Worksheets.Count)
        destWorkbook.Close saveChanges:=True
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"
    
End Sub

Again, working perfect!
Two more little things which would be nice if possible:
- if only certain xlsx files could be targetted? There might be some excel books which not need this extra sheet.
All workbooks that should be targetted are named something like "rapportage(additional number).xlsx"
- Now the extra sheet is placed at the end of sheets. Can I put it as second or third sheet? How is that done?

Really cool what is already made.. I'm very thankfull John!
 
Upvote 0
Just change the *.xlsx to rapportage*.xlsx. And to put the new sheet as the second sheet, use After:=destWorkbook.Worksheets(1), i.e. after the first sheet.

Code:
Public Sub Copy_Sheet_To_Workbooks_In_Subfolders()

    Dim copySheet As Worksheet
    Dim mainFolderPath As String
    Dim destWorkbook As Workbook
    Dim files As Variant
    Dim i As Long
    
    Set copySheet = ActiveWorkbook.Worksheets("Sheet1")   'change sheet name or number
    
    mainFolderPath = "C:\path\to\folder\"   'change this
    
    mainFolderPath = Trim(mainFolderPath)
    If Right(mainFolderPath, 1) <> "\" Then mainFolderPath = mainFolderPath & "\"
    
    files = Split(CreateObject("WScript.Shell").Exec("cmd /c DIR " & """" & mainFolderPath & "rapportage*.xlsx" & """" & " /B /S").StdOut.ReadAll, vbCrLf)
        
    Application.ScreenUpdating = False
    
    For i = 0 To UBound(files) - 1
        Set destWorkbook = Workbooks.Open(files(i))
        copySheet.Copy After:=destWorkbook.Worksheets(1)
        destWorkbook.Close saveChanges:=True
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"
    
End Sub
 
Upvote 0
Just change the *.xlsx to rapportage*.xlsx. And to put the new sheet as the second sheet, use After:=destWorkbook.Worksheets(1), i.e. after the first sheet.

Code:
Public Sub Copy_Sheet_To_Workbooks_In_Subfolders()

    Dim copySheet As Worksheet
    Dim mainFolderPath As String
    Dim destWorkbook As Workbook
    Dim files As Variant
    Dim i As Long
    
    Set copySheet = ActiveWorkbook.Worksheets("Sheet1")   'change sheet name or number
    
    mainFolderPath = "C:\path\to\folder\"   'change this
    
    mainFolderPath = Trim(mainFolderPath)
    If Right(mainFolderPath, 1) <> "\" Then mainFolderPath = mainFolderPath & "\"
    
    files = Split(CreateObject("WScript.Shell").Exec("cmd /c DIR " & """" & mainFolderPath & "rapportage*.xlsx" & """" & " /B /S").StdOut.ReadAll, vbCrLf)
        
    Application.ScreenUpdating = False
    
    For i = 0 To UBound(files) - 1
        Set destWorkbook = Workbooks.Open(files(i))
        copySheet.Copy After:=destWorkbook.Worksheets(1)
        destWorkbook.Close saveChanges:=True
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"
    
End Sub

Thank you so much John!! Appreciate the help!:ROFLMAO::ROFLMAO:
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,256
Members
448,558
Latest member
aivin

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