Macro to copy 2 worksheets into other workbooks

RPM7

Board Regular
Joined
Nov 28, 2007
Messages
191
I need a bit of help as my vba skills are pretty much non existant.
I have a spreadsheet that has multiple tabs and I need to copy 2 of the tabs into all of the spreadsheets that are within the same folder as the opened excel file.

Someone has already enquired about a similar application, but the code doesn't do exactly what I'm looking for.
https://www.mrexcel.com/forum/excel-questions/399744-copy-worksheet-multiple-workbooks.html

Code:
Option Explicit

Public Sub CopySheetToAllWorkbooksInFolder()

    Dim sourceSheet As Worksheet
    Dim folder As String, filename As String
    Dim destinationWorkbook As Workbook
    
    'Worksheet in active workbook to be copied as a new sheet to the 160 workbooks
    
    Set sourceSheet = ActiveWorkbook.Worksheets("Sheet1")
    
    'Folder containing the 160 workbooks
    
    folder = "F:\temp\excel\"
       
    filename = Dir(folder & "*.xls", vbNormal)
    While Len(filename) <> 0
        Debug.Print folder & filename
        Set destinationWorkbook = Workbooks.Open(folder & filename)
        sourceSheet.Copy before:=destinationWorkbook.Sheets(1)
        destinationWorkbook.Close True
        filename = Dir()  ' Get next matching file
    Wend

End Sub

If I edit the above code, I can copy a single tab into a specified folder.
I would like to copy two tabs into the same folder as the opened workbook. I'm just not sure how to specify them.
I work off multiple projects, so this spreadsheet will be duplicated and stored in different folders.

Another issue with the current code is that it doesn't overwrite the worksheets if they already exist in the destination workbooks.

Does anyone know how to modify the above code to suit?

Any help would be greatly appreciated.
 

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".
This will copy 'Sheet1' and 'Sheet2' into the other workbooks.
Code:
Option Explicit

Public Sub CopySheetToAllWorkbooksInFolder()
    Dim destinationWorkbook As Workbook
    Dim sourceWorkbook As Workbook
    Dim folder As String, filename As String
    
    'Worksheet in active workbook to be copied as a new sheet to the 160 workbooks
    
    Set sourceWorkbook = ActiveWorkbook

    'Folder containing the 160 workbooks
    
    folder = "F:\temp\excel\"
       
    filename = Dir(folder & "*.xls", vbNormal)
    While Len(filename) <> 0
        Set destinationWorkbook = Workbooks.Open(folder & filename)

        sourceWorkbook.Sheets(Array("Sheet1", "Sheet2")).Copy before:=destinationWorkbook.Sheets(1)

        destinationWorkbook.Close True
        filename = Dir()  ' Get next matching file
    Wend

End Sub
 
Upvote 0
Regarding the comment about deleting them if they already exist, are you only saving these 2 tabs, meaning if you open one of the 160 workbooks are there only 2 tabs and these are always to be overwrote or are you accumulating the 2 sheets into each of the workbooks?

Using the code Norie provided should work but will result in you getting Sheet1 (2) / Sheet 2 (2) if they already exist in the file.

If there are only supposed to be these 2 sheets in each file and they are overwrote each time then you could adjust it slightly. If you are storing them cumulatively then it will be a bit harder.

Code:
Public Sub CopySheetToAllWorkbooksInFolder()

    Dim sourceSheet1 As Worksheet
    Dim sourceSheet2 As Worksheet
    Dim folder As String, filename As String
    Dim destinationWorkbook As Workbook
    
    'Worksheet in active workbook to be copied as a new sheet to the 160 workbooks
    
    Set sourceSheet1 = ActiveWorkbook.Worksheets("Sheet1")
    Set sourceSheet2 = ActiveWorkbook.Worksheets("Sheet2")
    
    'Folder containing the 160 workbooks
    
    folder = "C:\Temp\Excel\"
       
    filename = Dir(folder & "*.xlsx", vbNormal)
    If filename = "Sheet1.xlsx" Then filename = Dir()
    While Len(filename) <> 0
        Debug.Print folder & filename
        Set destinationWorkbook = Workbooks.Open(folder & filename)
        sourceSheet2.Copy After:=destinationWorkbook.Sheets(1)
        Application.DisplayAlerts = False
        Sheets(1).Delete
        sourceSheet1.Copy Before:=destinationWorkbook.Sheets(1)
        Sheets(3).Delete
        Sheets(2).Name = "Sheet2"
        Application.DisplayAlerts = True
        destinationWorkbook.Close True
        filename = Dir()  ' Get next matching file
    Wend


End Sub
 
Last edited:
Upvote 0
Thanks for the replies Coding4Fun & Norie.

For reference, the main spreadsheet I'm copying this information from is like a master database which needs to be duplicated into other dependent spreadsheets.
Its a bit complicated, but these "dependent" spreadsheets feed into another software program which doesn't like linked cells
I thought that in order for me to make changes to every instance of the two worksheets, I would only need to update the master spreadsheet and it could copy over and update all the other spreadsheets.


Using the code Norie provided should work but will result in you getting Sheet1 (2) / Sheet 2 (2) if they already exist in the file.

If there are only supposed to be these 2 sheets in each file and they are overwrote each time then you could adjust it slightly. If you are storing them cumulatively then it will be a bit harder.

You're correct, I don't want to store the tabs cumulatively. They will be the data that drives a unique worksheet in each of the other workbooks.
Within these worksheets are defined ranges as well which wouldn't work if they're duplicated.
FYI: The worksheets are called "General_Data" & "Class_Data".
In your code, do I just replace every instance of "Sheet1" with "General_Data" and "Sheet2" with "Class_Data"?

Code:
Option Explicit

Public Sub CopySheetToAllWorkbooksInFolder()

    Dim sourceSheet1 As Worksheet
    Dim sourceSheet2 As Worksheet
    Dim folder As String, filename As String
    Dim destinationWorkbook As Workbook
    
    'Worksheet in active workbook to be copied as a new sheet to the 160 workbooks
    
    Set sourceSheet1 = ActiveWorkbook.Worksheets("General_Data")
    Set sourceSheet2 = ActiveWorkbook.Worksheets("Class_Data")
    
    'Folder containing the 160 workbooks
    
    folder = "C:\Temp\Excel\"
       
    filename = Dir(folder & "*.xlsx", vbNormal)
    If filename = "General_Data.xlsx" Then filename = Dir()
    While Len(filename) <> 0
        Debug.Print folder & filename
        Set destinationWorkbook = Workbooks.Open(folder & filename)
        sourceSheet2.Copy After:=destinationWorkbook.Sheets(1)
        Application.DisplayAlerts = False
        Sheets(1).Delete
        sourceSheet1.Copy before:=destinationWorkbook.Sheets(1)
        Sheets(3).Delete
        Sheets(2).Name = "Class_Data"
        Application.DisplayAlerts = True
        destinationWorkbook.Close True
        filename = Dir()  ' Get next matching file
    Wend


End Sub

I've tried the above code, but it doesn't seem to be working for me.
Any idea where I might have gone wrong?
 
Upvote 0
I changed the directory for my testing so that might be the issue, sorry if that is the case.
In your original post your directory was

Code:
[COLOR=#333333]folder = "F:\temp\excel\"[/COLOR]

Also is your file actually named "General_Data.xlsx"?

The code looks correct and so was your assumption

FYI: The worksheets are called "General_Data" & "Class_Data".
In your code, do I just replace every instance of "Sheet1" with "General_Data" and "Sheet2" with "Class_Data"?
 
Last edited:
Upvote 0
Thanks Coding4Fun.

I've changed the directory and the filename, but now its giving an error with a line in the code.
Code:
Sheets(3).Delete


With regards to the file location, is it possible to direct the macro to look into the current folder instead of having to edit the folder location every time I make a copy of this spreadsheet for future projects?

Thnks
 
Upvote 0
Give this a try

Code:
Option Explicit

Public Sub CopySheetToAllWorkbooksInFolder()


    Dim sourceSheet1 As Worksheet
    Dim sourceSheet2 As Worksheet
    Dim folder As String, filename As String
    Dim destinationWorkbook As Workbook
    Dim myLen As Integer
    
    'Worksheet in active workbook to be copied as a new sheet to the 160 workbooks
    
    Set sourceSheet1 = ActiveWorkbook.Worksheets("General_Data")
    Set sourceSheet2 = ActiveWorkbook.Worksheets("Class_Data")
    
    'Folder containing the 160 workbooks
    
    myLen = Len(ActiveWorkbook.FullName) - Len(ActiveWorkbook.Name)
  
    folder = Left(ActiveWorkbook.FullName, myLen) 'folder = "C:\Temp\Excel\"
       
    filename = Dir(folder & "*.xlsx", vbNormal)
    If filename = "Sheet1.xlsx" Then filename = Dir()
    While Len(filename) <> 0
        Debug.Print folder & filename
        Set destinationWorkbook = Workbooks.Open(folder & filename)
        
        While ActiveWorkbook.Sheets.Count > 1
        Application.DisplayAlerts = False
        Sheets(2).Delete
        Application.DisplayAlerts = True
        Wend
        
        sourceSheet2.Copy After:=destinationWorkbook.Sheets(1)
        Application.DisplayAlerts = False
        Sheets(1).Delete
        sourceSheet1.Copy before:=destinationWorkbook.Sheets(1)
        Sheets(2).Name = "Class_Data"
        Sheets(1).Name = "General_Data"
        Application.DisplayAlerts = True
        destinationWorkbook.Close True
        filename = Dir()  ' Get next matching file
    Wend




End Sub
 
Upvote 0
Thanks Coding4Fun.

That new code is inserting the tabs and overwriting them when rerunning the macro; however, it's also deleting any other tabs that are inside the newly updated workbooks.
When I open those spreadsheets, all that's there is the "General_Data" & "Class_Data" tabs.

Is there a way of only deleting worksheets called "General_Data" & "Class_Data"?

Also, the software I'm importing these workbooks in to looks for the last tab that was open when the spreadsheet was last saved.
when copying the tabs over, can they be moved to the end?
 
Upvote 0

Forum statistics

Threads
1,213,497
Messages
6,114,002
Members
448,543
Latest member
MartinLarkin

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