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..;)
 

Some videos you may like

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,429
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
 

HV_L

New Member
Joined
Dec 4, 2009
Messages
43
Thanks John,
Will try this in the weekend and post the results here.

Cheers
 

HV_L

New Member
Joined
Dec 4, 2009
Messages
43
Thanks John,
Will try this in the weekend and post the results here.

Cheers

Was too curious :) Working fine!!
Would it even be possible to include subfolders?? That would really be cool :)
Thnx
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,429

ADVERTISEMENT

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?
 

HV_L

New Member
Joined
Dec 4, 2009
Messages
43
I have one main folder, then there are about 250 subfolders, and each of these subfolders need to go three or four levels down
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,429

ADVERTISEMENT

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
 

HV_L

New Member
Joined
Dec 4, 2009
Messages
43
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!
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,429
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
 

HV_L

New Member
Joined
Dec 4, 2009
Messages
43
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:
 

Watch MrExcel Video

Forum statistics

Threads
1,109,205
Messages
5,527,399
Members
409,760
Latest member
zeeshansyed

This Week's Hot Topics

Top