Excel linked IF statement loses cell range following macro update - excel

I've created a basic macro within a workbook to clear data from a set number of tabs then copy in refreshed data from external workbooks. There is a master data tab within the workbook that uses IF formulas to obtain various stock information for that tab which then feeds through to other sheets.
E.G.
=IF($A$2="","",SUMIF(Data_CoventryStock!$A:$A,Data!$A$2,Data_CoventryStock!$E:$E))
Currently when the macro runs it produces the desired result but the IF Formulas lose the reference to the range e.g. $A:$A becomes #N/A!
I've been looking online for a solution but am unable to see a suitable option. I am new to this area.
Sub Update()
'
' Update Macro
'
Application.DisplayAlerts = False
' Clears data from tabs
Sheets("Data_10Day").Select
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Sheets("Data_CoventryStock").Select
Columns("A:E").Select
Selection.Delete Shift:=xlToLeft
Sheets("Data_CowleyStock").Select
Columns("A:E").Select
Selection.Delete Shift:=xlToLeft
Sheets("Data_RugbyStock").Select
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Sheets("Data_10Day").Select
' Copies data from other workbooks then pastes
Workbooks.Open Filename:= _
"C:\Users\ceasdown\Documents\HDS\Data\Data_10Day.xlsx"
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Windows("Coventry Ordering Template2.xlsm").Activate
Sheets("Data_10Day").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks("Data_10Day.xlsx").Close
Workbooks.Open Filename:= _
"C:\Users\ceasdown\Documents\HDS\Data\Data_CoventryStock.xlsx"
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Windows("Coventry Ordering Template2.xlsm").Activate
Sheets("Data_CoventryStock").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks("Data_CoventryStock.xlsx").Close
Workbooks.Open Filename:= _
"C:\Users\ceasdown\Documents\HDS\Data\Data_CowleyStock.xlsx"
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Windows("Coventry Ordering Template2.xlsm").Activate
Sheets("Data_CowleyStock").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks("Data_CowleyStock.xlsx").Close
Workbooks.Open Filename:= _
"C:\Users\ceasdown\Documents\HDS\Data\Data_RugbyStock.xlsx"
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Windows("Coventry Ordering Template2.xlsm").Activate
Sheets("Data_RugbyStock").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks("Data_RugbyStock.xlsx").Close
Application.DisplayAlerts = True
End Sub
I need it to retain the cell range in the IF formula so no manual update after running the macro is required.

The reason your formulas get damaged is that you are Deleting the ranges they refer to. Instead of deleting, use ClearContents instead.
Also, your code can do with quite a bit of optimsation.
Consider this
Sub Update()
Dim wbMain As Workbook
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Dim FilePath As String
Application.DisplayAlerts = False
Set wbMain = ActiveWorkbook
With wbMain
FilePath = Environ$("UserProfile") & "\Documents\HDS\Data\"
' Copies data from other workbooks then pastes
UpdateFromWB .Worksheets("Data_10Day").Cells(1, 1), FilePath & "Data_10Day.xlsx", "WhatSheet?"
UpdateFromWB .Worksheets("Data_CoventryStock").Cells(1, 1), FilePath & "Data_CoventryStock.xlsx", "WhatSheet?"
UpdateFromWB .Worksheets("Data_CowleyStock").Cells(1, 1), FilePath & "Data_CowleyStock.xlsx", "WhatSheet?"
UpdateFromWB .Worksheets("Data_RugbyStock").Cells(1, 1), FilePath & "Data_RugbyStock.xlsx", "WhatSheet?"
End With
Application.DisplayAlerts = True
End Sub
Private Sub UpdateFromWB(rngDest As Range, wbName As String, wsName As String)
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Set wb = Workbooks.Open(Filename:=wbName)
Set ws = wb.Worksheets(wsName)
With ws
Set rng = .Range(.Cells(1, 1).End(xlDown), .Cells(1, 1).End(xlToRight))
'Alternative, in case there might be gaps in the data
'Set rng = .Range(.Cells(.Rows.Count, 1).End(xlUp), .Cells(1, .Columns.Count).End(xlToLeft))
End With
rngDest.Worksheet.Cells.ClearContents 'Delets ALL data from sheet. Adjust range if required
rngDest.Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
wb.Close
End Sub

I try to create a code avoiding .Select, .Activate and repetition. The code is untested but it will give you an idea about the concept. For any question please ask me.
Option Explicit
Sub Update()
Dim ws As Worksheet
'
' Update Macro
'
Application.DisplayAlerts = False
' Clears data from tabs
For Each ws In ThisWorkbook
With ws
If .Name = "Data_10Day" Or .Name = "Data_RugbyStock" Then
.Columns("A:B").Delete Shift:=xlToLeft
ElseIf .Name = "Data_CoventryStock" Or .Name = "Data_CowleyStock" Then
.Columns("A:E").Delete Shift:=xlToLeft
End If
End With
Next ws
' Copies data from other workbooks then pastes
Call Procedure("Data_10Day.xlsx", "Data_10Day")
Call Procedure("Data_CoventryStock.xlsx", "Data_CoventryStock")
Call Procedure("Data_CowleyStock.xlsx", "Data_CowleyStock")
Call Procedure("Data_RugbyStock.xlsx", "Data_RugbyStock.xlsx")
Application.DisplayAlerts = True
End Sub
Sub Procedure(ByVal FileName As String, ByVal SheetName As String)
Workbooks.Open FileName:="C:\Users\ceasdown\Documents\HDS\Data\" & FileName
Workbooks(FileName).Sheets("Sheet1").UsedRange.Copy
Workbooks("Coventry Ordering Template2.xlsm").Sheets(SheetName).Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(FileName).Close
End Sub

Related

How to add data daily on the first blank line? Canteen example

I have the following set of code to record daily employees who eat lunch in the canteen. What change is needed so that when the person clicks on the macro button every day, the data is on the 1st blank line (from column A) of the "dados_diarios" sheet?
This is so that at the end of the month I have a list of all the days.
Sub outros_diario()
Sheets("outros").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Workbooks.Open ("N:\RH\Cantina\Lista_OUTROS.xlsx")
Windows("Lista_OUTROS.xlsx").Activate
Cells.Select
Selection.Copy
Windows("outros.xlsm").Activate
Sheets("outros").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
ActiveWindow.DisplayGridlines = False
Range("B8:O1000").Select
Selection.Copy
Sheets("dados_diarios").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("C2:F1000").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("E2:H1000").Select
Selection.Delete Shift:=xlToLeft
Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
Range("H8").Select
Columns("C:C").EntireColumn.AutoFit
End Sub
Give this a go. You may want to add back in your DisplayGridlines= False and the deletion of cells at the end - but it should give you a much better start than where you're up to right now:
Sub outros_diario()
'declarations
Dim last_row_source As Long
Dim last_row_destination As Long
Dim source_book As Workbook
Dim source_sheet As Worksheet
Dim dest_sheet1 As Worksheet
Dim dest_sheet2 As Worksheet
'set references to the two paste destinations
Set dest_sheet1 = ThisWorkbook.Sheets("outros")
Set dest_sheet2 = ThisWorkbook.Sheets("dados_diarios")
'delete-clear sheet: outros
dest_sheet1.Cells.Delete Shift:=xlUp
'open the workbook as reference 'source_book'
Set source_book = Workbooks.Open("N:\RH\Cantina\Lista_OUTROS.xlsx")
'set a reference to the activesheet and call it 'source_sheet'
Set source_sheet = source_book.ActiveSheet
'copy source_sheet to dest_sheet1 [outros]
source_sheet.Cells.Copy dest_sheet1.Range("A1")
'find where the data now stops on the [outros]
last_row_source = dest_sheet1.Cells(dest_sheet1.Rows.Count, "B").End(xlUp).Row
'find where the data stops on [dados_diarios]
last_row_destination = dest_sheet2.Cells(dest_sheet2.Rows.Count, "B").End(xlUp).Row
'copy data values from [outros] to [dados_diarios] ignoring first 7 rows
dest_sheet2.Range("A" & last_row_destination + 1).Resize(last_row_source - 7, 14).Value = dest_sheet1.Range("B8:O" & last_row_source).Value
'close the source workbook, without saving
source_book.Close False
End Sub

Information regarding the Run time error 9

I am trying to copy the range of value from one sheet in excel to another. I have copied this formula from another part of my sheet that works however i cam coming up with the run time error 9.
Sub SaveJambStudEC()
'
' SaveCalcsJambEC Macro
'
Dim page As Integer
page = Cells(4, "T").Value
Range("A70:AN70").Select
Selection.Copy
Range("A71").Select
ActiveCell.Offset(page, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1:O63").Select
Selection.Copy
Sheets("10.3 JambCalcs EC").Select
Range("A1").Select
ActiveCell.Offset((page - 1) * 63, 0).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats
Sheets("9.3 Jamb Design EC").Select
Range("T5").Select
Selection.Copy
Range("N9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("T31").Value = 0
Call JambECsetDesignOptions
Call CopyJambOptiValues
Range("J9").Activate
End Sub
using the below code you will check if there is a sheet with that name. if you dont receive any message box means that there is no sheet with such name
Option Explicit
Sub test()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "10.3 JambCalcs EC" Then
MsgBox "Sheet Appears"
Exit Sub
End If
Next ws
End Sub
Note
'ThisWorkbook' refer to the workbook that the code included. If you want to clearly declare the workbook you could declare a variable 'Dim wb as Workbook' and then set the workbook 'Set wb=Workbooks("workbook name")'

Loop that references different sheet names each iteration

I have the following loop to create multiple tabs in Excel 2016 based on a list of PO#'s. ( see code below)
Sub CreateSheetsFromAList()
Dim MyRange As Range
Dim dic As Object, c As Range
Dim k As Variant, tmp As String
Set dic = CreateObject("scripting.dictionary")
Set MyRange = Sheets("Instructions").Range("h6")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Sheets("Template").Visible = True
For Each c In MyRange
tmp = Trim(c.Value)
If Len(tmp) > 0 Then dic(tmp) = dic(tmp) + 1
Next c
For Each k In dic.keys
If Not WorksheetExists(k) Then
Sheets("Template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = k
End If
Next k
End Sub
Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (Sheets(WorksheetName).Name <> "")
On Error GoTo 0
End Function
I also need to populate each newly created tab with info from another workbook (EDI PO Consolidated - 2018.xlsx)
(see code below)
Sub BandB2()
' BandB2 Macro
' Keyboard Shortcut: Ctrl+b
'
Application.Goto Reference:="R20C10"
Selection.Copy
Windows("EDI PO Consolidated - 2018.xlsx").Activate
ActiveSheet.Range("$A$1:$X$2628").AutoFilter Field:=2, Criteria1:= _
"34535453"
Application.Goto Reference:="R1C9"
Range("I2058").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book and Bill form - template.xlsm").Activate
Range("J26").Select
ActiveSheet.Paste
Windows("EDI PO Consolidated - 2018.xlsx").Activate
ActiveWindow.SmallScroll ToRight:=4
Application.Goto Reference:="R1C17"
Range("Q2058").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book and Bill form - template.xlsm").Activate
ActiveWindow.SmallScroll Down:=6
Range("C33").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("EDI PO Consolidated - 2018.xlsx").Activate
Application.Goto Reference:="R1C14"
Range("N2058").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book and Bill form - template.xlsm").Activate
Range("D33").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("EDI PO Consolidated - 2018.xlsx").Activate
Application.Goto Reference:="R1C18"
Range("R2058:T2058").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book and Bill form - template.xlsm").Activate
Range("E33").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
I have 2 questions:
1) i cannot make the sheet reference change for each tab; it always picks the
1st po# "34535453"
2) Can you help me combine these into 1 macro.
thank you in advance for your help
Here's a cleaner way to create those tabs.
Name cell H6 on the Instructions tab "PO_Start" or some other appropriate name. That way if you can insert rows or columns on the tab without possibly having to change the reference to H6 in your code.
Sub Create_Sheets()
Dim PO_list, PO As Range
Set PO_list = Range(Sheets("Instructions").Range("PO_Start"), Sheets("Instructions").Range("PO_Start").End(xlDown))
Sheets("Template").Visible = True
For Each PO In PO_list
If Not WorksheetExists(PO) Then
Sheets("Template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = PO
End If
Next PO
End Sub
1) To loop through your tabs, if you know that your PO tabs will always start on tab 3, you can loop through the sheets like this (including variable declarations):
Sub B_and_B()
Dim ws As Worksheet
Dim i As Integer
For i = 3 To Sheets.Count
Set ws = Sheets(i)
'... rest of code here
Next i
End Sub
Otherwise if down the road you anticipate adding other sheets besides "Instructions" and "Template" to your Book and Bill file, you could loop through all sheets, error checking to see if you can convert the sheet name to a "long" variable type with Clng(). Probably more than what's needed for your current project.
Another tip:
Avoid using hard-coded cell addresses ("N2058") in your code. If you filter on purchase orders in the Consolidated book and then pull in certain data elements, you'll need to find the row the Purchase Order is in (2058 in this case).
2) To combine these into one macro, you can create a Main subroutine, calling each step separately:
Sub Main()
Call Create_Sheets
Call B_and_B
End Sub

Filtering excel rows in hidden mode (VB Code)

I want to filter an extensive range of rows in Excel and copy their values without the filter running in Excel, only in VB code without visual action in Excel.
This procedure is very slow, I want a more agile alternative:
'
xlSheet.Range("A1:Z100000").AutoFilter(1, "Criteria", , , False)
xlSheet.Range("C1:F100000").Copy()
xlSheet2.Range("A1").PasteSpecial(Paste:=XlPasteType.xlPasteValues, Operation:=XlPasteSpecialOperation.xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False)
Application.CutCopyMode = CType(False, XlCutCopyMode)
xlSheet.Range("A1:Z100000").AutoFilter(False)
'
Any suggestions? Thanks !
I would like to suggest this Code for the issue,,
Sub Exception_Review()
Application.ScreenUpdating = False
Dim FilterCriteria Dim CurrentsheetName As String Dim NewFileName As String 'Get the current sheets's name CurrentsheetName = ActiveSheet.Name
Range("A2:K25").Select
Selection.AutoFilter Selection.AutoFilter field:=13, Criteria1:="No" Selection.SpecialCells(xlCellTypeVisible).Select Selection.Copy Worksheets.Add ActiveSheet.Name = "ExceptionReview" Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Cells.Select Selection.Columns.AutoFit Range("A1").Select (CurrentsheetName).Activate Selection.AutoFilter field:=1
Selection.AutoFilter
Range("A1").Select Application.ScreenUpdating = True
End Sub

call Sub not working properly

Why this call of sub is not working properly?
I get an error that there are undefined objects.
I believe this can be a little problem but cannot find a solution.
I am trying to make new sheetnames but the code is too long for VBA , so I have to split the code, and continue in a second Sub. (apparently it is limited to 15 of 16 handlings)
Thanks in advance.
below my startcode
Sub Macro1()
' Macro1 Macro
Dim wbNew As Workbook
'sheet 1----------------------------------------------------------------
Application.ScreenUpdating = False
ThisWorkbook.Sheets(1).Activate
Range("A1:S53").Select
Range("S53").Activate
Selection.Copy
Set wbNew = Workbooks.Add
wbNew.Sheets(1).Activate
Range("A1:S53").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
wbNew.Sheets(1).Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
ActiveSheet.Paste
Range("A15").Select
Call vanaf_17
ActiveWorkbook.SaveAs Filename:= _
"C:\Path\" & "per 1-15" & " " & Format(Range("C13"), "mmmm") & " " & Format(Range("C13"), "YYYY") & ".xlsx"
FileFormat = xlOpenXMLWorkbook
ActiveWindow.Close
End Sub
code to call
Sub vanaf_17()
Dim wbNew As Workbook
Application.ScreenUpdating = False
'sheet 17----------------------------------------------------------------
'here starts a new sheet!!!!!!!!!!!!!
Sheets.Add After:=ActiveSheet
ThisWorkbook.Sheets(1).Activate
Range("A1:S53").Select
Range("S53").Activate
Selection.Copy
'change here sheet nr!!!!!!!
wbNew.Sheets(17).Activate
Range("A1:S53").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'change here sheet nr!!!!!!!
wbNew.Sheets(17).Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
ActiveSheet.Paste
'Here ends a new sheet!!!!!
End Sub
You'll need to set wbnew in that second sub as well. The second sub has no idea what you mean when you say wbnew. When you have a variable in a subroutine or function it exists only in the subroutine or function. As soon as you move to another subroutine, your variables are 100% worthless.
To get around this, you can pass parameters between subs.
When you start your second sub Sub vanaf_17() Do it like so:
Sub vanaf_17(wbNew as Workbook)
....your code
End Sub
When you call vanaf_17() do it like so:
Call vanaf_17 webNew
Also, since you are declaring webNew as a workbook in the parameters, delete the dim wbNew as Workbook bit in vanaf_17 otherwise you'll get an error.
Lastly, There is no reason why you need to split these up into two subroutines. I've never heard of '15 or 16 handling' limit and I'm not real sure what that means. I've seen some ugly ass recorded macro code that goes on for thousands of lines of .select and .activate and oh-my-god-no-that-is-such-a-bad-idea for what feels like forever. Excel can handle it.
Updated: Here is what the code would look like with this change:
Sub Macro1()
' Macro1 Macro
Dim wbNew As Workbook
'sheet 1----------------------------------------------------------------
Application.ScreenUpdating = False
ThisWorkbook.Sheets(1).Activate
Range("A1:S53").Select
Range("S53").Activate
Selection.Copy
Set wbNew = Workbooks.Add
wbNew.Sheets(1).Activate
Range("A1:S53").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
wbNew.Sheets(1).Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
ActiveSheet.Paste
Range("A15").Select
Call vanaf_17 wbNew
ActiveWorkbook.SaveAs Filename:= _
"C:\Path\" & "per 1-15" & " " & Format(Range("C13"), "mmmm") & " " & Format(Range("C13"), "YYYY") & ".xlsx"
FileFormat = xlOpenXMLWorkbook
ActiveWindow.Close
End Sub
Sub vanaf_17(wbNew AS Workbook)
Application.ScreenUpdating = False
'sheet 17----------------------------------------------------------------
'here starts a new sheet!!!!!!!!!!!!!
Sheets.Add After:=ActiveSheet
ThisWorkbook.Sheets(1).Activate
Range("A1:S53").Select
Range("S53").Activate
Selection.Copy
'change here sheet nr!!!!!!!
wbNew.Sheets(17).Activate
Range("A1:S53").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'change here sheet nr!!!!!!!
wbNew.Sheets(17).Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
ActiveSheet.Paste
'Here ends a new sheet!!!!!
End Sub
That being said, there are some changes here that I think will help. Namely, you could loop through all the sheets that you care about in thisWorkbook, and call your subroutine to copy and paste the A1:S53 range into a new worksheet in the new workbook. Below I have a quick example of what that would look like. I kept some of the unnecessary .select and .activate stuff in there, because I figured this change was dramatic enough. You'll see that all of your sheet creation and copying/pasting is now done in the second subroutine. The first subroutine just sets up the new workbook, loops through the sheets, and then saves the new workbook.
Sub Macro1()
' Create a new workbook. Then loop through each worksheet in this workbook (that we care about)
' and call the CreateNewWS subroutine to copy the A1:S53 range for each worksheet into the
' new workbook
Application.ScreenUpdating = False
'Create a new workbook, assign it to wbNew variable
Dim wbNew As Workbook
Set wbNew = Workbooks.Add
'Loop through all the sheets in the current workbook that we care about
Dim sheetname as string
For each sheetname in Array("sheet1", "sheet2", "sheet3", "sheet4")
'call the CreateNewWS subroutine to do the sheet creation and copying and pasting
call CreateNewWS wbNew, thisWorkbook.Sheets(sheetname)
Next sheetname
'You could also loop through all of the worksheets in thisworkbook if you want to copy every worksheet:
'Dim ws as worksheet
'For each ws in ThisWorkbook.Worksheets
' call CreateNewWS wbNew, ws
'Next ws
'Save the new workbook
newWb.SaveAs Filename:= _
"C:\Path\" & "per 1-15" & " " & Format(Range("C13"), "mmmm") & " " & Format(Range("C13"), "YYYY") & ".xlsx"
FileFormat = xlOpenXMLWorkbook
'Close the new workbook
newWb.Close
'Don't forget to turn this back on. Yikes.
Application.ScreenUpdating = True
End Sub
Sub CreateNewWS(wbNew AS Workbook, ws as Worksheet)
'This subroutine takes in the wbNew and the worksheet (ws) that we are copying from.
' it copys range A1:S53 from the ws to the wbNew's new worksheet.
'This will hold the new worksheet we are adding to the wbNew
Dim wsNew as worksheet
'Add a new worksheet to the new workbook
wbNew.Activate
set wsNew = wbNew.Sheets.Add After:=ActiveSheet
'Activate and copy from current workbook
ws.Activate
ws.Range("A1:S53").Select
Selection.Copy
'Activate and paste into newWb
wsNew.Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End Sub
I haven't really tested this change, but the guts of it are accurate. If you do decide to switch over to this type of logic and you run into errors, it would be prudent to create a new stackoverflow question to work through the problem.

Resources