I'm trying to copy a worksheet ("blank") multiple times based on the Inputs sheet. Each row of the input sheet represents the information to copy and paste to the newly copied sheets. I have attempted this in two different ways to accomplish.
Here is code #1
Sub AddSheets()
Dim codes As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Sheets("Inputs").Select
For Each i In Range("Codes")
On Error GoTo ErrMsg
Range("b6:cp6").Select
Sheets.Add After:=ActiveSheet
ActiveSheet.name = i
n = ActiveSheet.name
Sheets("Blank").Select
Cells.Select
Selection.Copy
Sheets(n).Select
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteAll
Sheets("Inputs").Select
Selection.Offset(1, 0).Activate
Selection.Copy
Sheets(n).Select
Range("b3").Select
ActiveSheet.Paste Link:=True
ActiveSheet.Range("b3").PasteSpecial Paste:=xlPasteFormats
ActiveWindow.DisplayGridlines = False
Next i
Sheets("Inputs").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
ErrMsg:
MsgBox ("Delete Old Sheets Before Creating New.")
End Sub
The only issue I have with code #1 is that it takes a really long time to process. I need this to create over 500+ sheets and most of the time ends up not responding. So I searched for another way.
Here is code #2
Function CheckSheetExists(ByVal name As String)
Dim retVal As Boolean
retVal = False
For S = 1 To Sheets.Count
If Sheets(S).name = name Then
retVal = True
Exit For
End If
Next S
CheckSheetExists = retVal
End Function
Sub AutoAddSheet()
Dim MyCell As Range, MyRange As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Set MyRange = Sheets("Inputs").Range("B7")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
If CheckSheetExists(MyCell.Value) = False Then
Sheets("Blank").Copy After:=Sheets(Sheets.Count)
With Sheets(Sheets.Count)
.name = MyCell.Value
.Cells(2, 1) = MyCell.Value 'can this be removed
End With
End If
Next MyCell
Sheets("Inputs").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Option #2 actually now has 2 different problems, (1) is that I still need to copy the input schedule data and (2) as the sheet counts get higher it sometimes doesn't respond trying to add any additional sheets.
Any thoughts on which route would be best? Also, how can I fix the problems that I'm facing.
Bookmarks