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