Solved

Script or Macro to copy workbook to multiple workbooks Excel

Posted on 2011-09-21
5
402 Views
Last Modified: 2012-05-12
Hi,

I have a total of 100 workbooks in a folder and sub folders. I would like to be able to add another workbook as a new tab to each of the 100 workbooks mentioned previously. Is the best way to do this using a VB Script? Or would a macro be more suitable for this task. I have attempted to write a script to do it but having little experience, this is beyond me. I have tried to write a script that will reference a list containing the files required to be opened (100 workbooks). Once opened the script will add the existing worksheet as a new tab. Alas, I am unable to do so.

Does anyone have a script that can get me started or any pointers would be appreciated?

Thanks in advance
0
Comment
Question by:Mattywerts
  • 4
5 Comments
 
LVL 5

Accepted Solution

by:
slycoder earned 500 total points
ID: 36578564
I have this setup in Safe Mode.  When you are ready to change the 100 files, please do so on a copy of them in another directory or on another drive.  This will be so you can see what the macro does, and your original files will not be damaged if the outcome is undesirable.

Thanks
 
Dim r As Long
Dim myFileList(101) As String

' WARNING - Please run this on a duplicate tree (not your original files) first
' this macro does not delete anything, but there is no "undo" of the additional sheets

' Set these to what your setup
Const myRoot = "g:\spreadsheets"
Const mySheetName = "NewWorksheet"

Public Sub main()
    r = 0
    ' and include subfolders (true/false)
    ListFolders myRoot, True
    
    ' Uncomment to display list of files in Immediate Window (debugging)
    Call showfiles
    
    ' Comment this line out if debugging and you do not wish to change the sheets yet.
    ' Call AddSheetToEachFile
End Sub


Public Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
    DoEvents
    Application.DisplayAlerts = False
    
    Dim fso As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
    
    
    Set fso = New Scripting.FileSystemObject
    Set SourceFolder = fso.GetFolder(SourceFolderName)
    
    On Error Resume Next
    
    Findfiles (SourceFolder.Path)
    
    If IncludeSubfolders Then
    
        For Each SubFolder In SourceFolder.SubFolders
            ListFolders SubFolder.Path, True
        Next SubFolder
        
        Set SubFolder = Nothing
    
    End If
    
    Set SourceFolder = Nothing
    Set fso = Nothing
    
End Sub


Public Sub Findfiles(d As String)

    fname = Dir(d & "\*.*")
    
    Do While fname <> ""
        myFileList(r) = d & "\" & fname
        r = r + 1
        fname = Dir
    Loop
End Sub

Sub AddSheetToEachFile()
    Dim myFile As Variant
    
    For Each myFile In myFileList
        If myFile <> "" Then
            Debug.Print myFile
        
            Workbooks.Open Filename:=myFile
            Sheets.Add After:=Sheets(Sheets.Count)
            Sheets(ActiveSheet.Name).Select
            Sheets(ActiveSheet.Name).Name = mySheetName
            ActiveWorkbook.Save
            ActiveWorkbook.Close
        End If
    Next myFile
    
End Sub


Public Sub showfiles()
    ' Can be called for debugging
    Dim myFile As Variant
    
    For Each myFile In myFileList
        If myFile <> "" Then
            Debug.Print myFile
        End If
    Next myFile
End Sub

Open in new window

0
 
LVL 5

Expert Comment

by:slycoder
ID: 36578572
It's late here - forgot to tell you - a reference to "Microsoft Scripting Runtime" is required to work with the FileSystemObject.

Please add this in the Macro IDE (Alt+F11) by selecting - Tools - References "Microsoft Scripting Runtime"

Thanks
0
 
LVL 5

Expert Comment

by:slycoder
ID: 36578589
>> Is the best way to do this using a VB Script? Or would a macro be more suitable for this task.

Either way really would work.  I use Excel in this solution so that I can "see" what I'm doing with the immediate window.  Also since you already have an instance of Excel opened, you can leverage the objects easier.

Thanks
0
 
LVL 5

Expert Comment

by:slycoder
ID: 36578604
One last note - make sure the file containing this macro is not in the set being processed.  I made that mistake and the program halted gracefully.  

I named the worksheet g:\MasterTemplateArray.xlsm and processed the files in g:\Spreadsheets.

Thanks.


0
 
LVL 1

Author Closing Comment

by:Mattywerts
ID: 36578686
Exactly what I was looking for. Thanks heaps
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

PaperPort has a feature called the "Send To Bar". It provides a convenient, drag-and-drop interface for using other installed software, such as Microsoft Office. However, this article shows that the latest Office 2016 apps (installed with an Office …
Entering a date in Microsoft Access can be tricky. A typo can cause month and day to be shuffled, entering the day only causes an error, as does entering, say, day 31 in June. This article shows how an inputmask supported by code can help the user a…
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.

895 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

17 Experts available now in Live!

Get 1:1 Help Now