VBA to copy worksheet from one workbook to all workbooks in another folder

Question

Add worksheet to workbook using VBA

I am looking to copy an existing (already created worksheet) into about 500 workbooks (*.xlsx) that all reside in the same folder. I was able to cobble together the below code from various other topics on here but I am not able to get it to work.

Private Sub Command0_Click()

   Dim file As String
   Dim myPath As String
   Dim wb As Workbook
   Dim rng As Range

   Dim wbMaster As Workbook
   'if master workbook already opened
   'Set wbMaster = Workbooks("ProjectBabelfish.xlsx")
   'if master workbook is not opened
   Set wbMaster = Workbooks.Open(CurrentProject.Path & "\ProjectBabelfish.xlsx")

   Set rng = wbMaster.Sheets("Babelfish").Range("A1:CC200")

   myPath = CurrentProject.Path & "\PLOGs\" ' note there is a back slash in the end"
   file = Dir(myPath & "*.xlsx*")
   While (file <> "")

        Set wb = Workbooks.Open(myPath & file)
        rng.Copy
        With wb.Worksheets("Babelfish").Range("A1")
            .PasteSpecial xlPasteColumnWidths
            .PasteSpecial xlPasteAll
        End With

        wb.Close SaveChanges:=True
        Set wb = Nothing

        file = Dir
    Wend

    Application.CutCopyMode = False

End Sub

Other than simply copying the worksheet from workbook to another, the formulas need to reference cells in the new workbook. Also, I am trying to account for some of the workbooks being locked.

Answer 1

Something like this should work for you:

Sub Command0_Click()

    Dim wbMaster As Workbook
    Set wbMaster = ThisWorkbook

    Dim wsCopy As Worksheet
    Set wsCopy = wbMaster.Worksheets("Babelfish")

    Dim sFolderPath As String
    sFolderPath = wbMaster.Path & "\PLOGs\"
    If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"

    Dim sFileName As String
    sFileName = Dir(sFolderPath & "*.xlsx")

    'Disable screenupdating (to prevent "screen flickering" so macro runs smoother)
    'Disable alerts (to suppress "Are you sure?" prompts during worksheet deletion)
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    'Begin loop through files in the folder
    Do While Len(sFileName) > 0

        Dim sWBOpenPassword As String
        Dim sWBProtectPassword As String
        Select Case sFileName
            'Specify workbook names that require passwords here
            Case "Book2.xlsx", "Another Protected File.xlsx", "Third generic password file.xlsx"
                sWBOpenPassword = "password"
                sWBProtectPassword = "secondpassword"

            'If different books require different passwords, can specify additional names with their unique passwords
            Case "Book3.xlsx"
                sWBOpenPassword = "book3openpassword"
                sWBProtectPassword = "book3protectionpassword"

            'Keep specifying excel file names and their passwords until completed
            Case "Book10.xlsx", "Book257.xlsx"
                sWBOpenPassword = "GenericOpenPW2"
                sWBProtectPassword = "GenericProtectPW2"

            'etc...


            'Case Else will handle the remaining workbooks that don't require passwords
            Case Else
                sWBOpenPassword = ""
                sWBProtectPassword = ""

        End Select

        'Open file using password (if any)
        With Workbooks.Open(sFolderPath & sFileName, , , , Password:=sWBOpenPassword)

            Dim bProtectedWB As Boolean
            bProtectedWB = False    'Reset protected wb check to false

            'Check if workbook is protected and if so unprotect it using the specified protection password
            If .ProtectStructure = True Then bProtectedWB = True
            If bProtectedWB = True Then .Unprotect sWBProtectPassword

            On Error Resume Next    'Suppress error if copied worksheet does not yet exist
            .Worksheets(wsCopy.Name).Delete 'Delete existing sheet if it exists
            On Error GoTo 0         'Remove "On Error Resume Next" condition


            wsCopy.Copy After:=.Worksheets(.Worksheets.Count)   'Copy template into the workbook
            .Worksheets(wsCopy.Name).Cells.Replace wbMaster.Name, .Name 'Change references from master workbook to current workbook

            'If workbook was protected, reprotect it with same protection password
            If bProtectedWB = True Then .Protect sWBProtectPassword

            'Close file and save the changes
            .Close True
        End With

        sFileName = Dir 'Advance to next file in the folder
    Loop

    'Re-enable screenupdating and alerts
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub