Inserting a 5th worksheet on multiple existing protecteWkBk

[jolas]

I like some assistance please. I have hundreds of protected Workbook (no password - more on convenience than security) in a folder consisting of 4 worksheets. The workbook template that form the basis of the existing workbooks needed to have a 5th worksheet added to the end of the workbook. How do I automate adding the 5th worksheet from the workbook template to multiple existing workbooks?

I would like to also insert or correct the formula on cell B1:C1 of the inserted worksheet so as to reflect the same value as that of the cell B1:C1 of the first worksheet. The formula of the merged cell B1:C1 of the inserted 5th worksheet would still refer to the source workbook worksheets as an external link thus the need to correct it. At least this is true when I manually do it.

I would like to also protect the workbook (no password also) before saving. Is this do-able

I am attaching the source workbook template. The existing workbooks are using the value of cell B1:C1 as its file name.

Appreciate any assistance.

[HansV]

Try this version of the macro:

Code: Select all

Public Sub CopySheetToAllWorkbooksInFolder()
    Dim sourceSheet As Worksheet
    Dim folder As String, filename As String
    Dim destinationWorkbook As Workbook
    Dim destinationSheet As Worksheet

    'Worksheet in active workbook to be copied as a new sheet to the workbooks
    Set sourceSheet = ThisWorkbook.Worksheets("MathContinuum")

    'Folder containing the workbooks
    folder = "R:\Continuum\"

    Application.ScreenUpdating = False
    filename = Dir(folder & "*.xls", vbNormal)
    Do While filename <> ""
        Debug.Print folder & filename
        Set destinationWorkbook = Workbooks.Open(folder & filename)
        sourceSheet.Copy After:=destinationWorkbook.Sheets(destinationWorkbook.Sheets.Count)
        Set destinationSheet = destinationWorkbook.Sheets(destinationWorkbook.Sheets.Count)
        destinationSheet.Range("B1").Formula = "='Learner Profile'!B1"
        destinationWorkbook.Protect
        destinationWorkbook.Close True
        filename = Dir  ' Get next matching file
    Loop
    Application.ScreenUpdating = True
End Sub

[jolas]

Wow this is great. Hans I know you are quick but you are much faster than I thought. very much appreciate your help.

[jolas]

Another similar request please.

Based on the updated continuum workbook template attached. I have created hundreds of workbooks on a folder. I would like to copy a range (A43:K54) from the first worksheet (Learner Profile) of this template workbook to exactly the same range address of a similarly name worksheet. The target worksheet may need to be unprotected first before copying and then re-protected before saving. The process looped until all the worbook in the folder are processed.

Appreciate any assistance.

Thanks.

[HansV]

Does this do what you want? Make sure to test on a copy of the workbooks first (or make a backup before testing)!

Code: Select all

Public Sub CopyRangeToAllWorkbooksInFolder()
  Dim sourceSheet As Worksheet
  Dim folder As String, filename As String
  Dim destinationWorkbook As Workbook
  Dim destinationSheet As Worksheet
  Dim blnProtection As Boolean

  'Worksheet in active workbook
  Set sourceSheet = ThisWorkbook.Worksheets("Learner Profile")

  'Folder containing the workbooks
  folder = "R:\Continuum\"

  Application.ScreenUpdating = False
  filename = Dir(folder & "*.xls", vbNormal)
  Do While filename <> ""
    Debug.Print folder & filename
    Set destinationWorkbook = Workbooks.Open(folder & filename)
    Set destinationSheet = destinationWorkbook.Worksheets("Learner Profile")
    blnProtection = destinationSheet.ProtectContents
    If blnProtection = True Then
      destinationSheet.Unprotect
    End If
    sourceSheet.Range("A43:K54").Copy Destination:=destinationSheet.Range("A43:K54")
    If blnProtection = True Then
      destinationSheet.Protect
    End If
    destinationWorkbook.Close True
    filename = Dir  ' Get next matching file
  Loop
  Application.ScreenUpdating = True
End Sub

[jolas]

Sir you are really a very helpful man. Thank you very much and have a wonderful day!