Copy push sheet

[HV_L]

Hi,
I have a bunch of workbooks, now I want a extra sheet copied in all my existing workbooks.
Is that possible via VBA?

Appreciate the help..

 

[John_w]

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.

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]

Thanks John,
Will try this in the weekend and post the results here.

Cheers

 

[HV_L]

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]

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]

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]

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.

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]

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.

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]

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.

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]

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.

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!