Sub Create()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ws, ws1, wsN As Worksheet
Dim NewName As String, msg As String
Dim LastColumn As Long
Dim rng As Range
Set ws1 = Sheet9
Do
Set wsN = Nothing
NewName = InputBox("What name for the new sheet?" & vbLf & msg)
On Error Resume Next
Set wsN = Sheets(NewName)
msg = "'" & wsN.Name & "' already exists as a sheet name"
On Error GoTo 0
Loop Until wsN Is Nothing
If Len(NewName) > 0 Then Sheets.Add(After:=Sheets(Sheets.count)).Name = NewName
Set ws = ActiveSheet
With ws1
'.Rows("38:38").UnMerge
.Range("I27:X34").COPY
With ws.Range("A1")
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End With
.Range("I38:J137").COPY
With ws.Range("A12")
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Range("A13:B17").Delete Shift:=xlUp
End With
End With
With ws
.Rows("23:23").EntireRow.Hidden = True
.Rows("39:39").EntireRow.Hidden = True
.Rows("43:43").EntireRow.Hidden = True
.Rows("45:45").EntireRow.Hidden = True
.Rows("48:49").EntireRow.Hidden = True
.Rows("64:106").EntireRow.Hidden = True
.Rows("41:41").RowHeight = 6
.Rows("47:47").RowHeight = 6
End With
Dim lc As Long
Dim c As Long
Dim sc As Long
sc = 3
lc = ws1.Cells(44, Columns.count).End(xlToLeft).Column
With ws1
For c = 1 To lc
If .Cells(45, c) = "Y" Then
.Range(.Cells(44, c), .Cells(94, c)).COPY
With ws.Cells(13, sc)
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats
Application.CutCopyMode = False
End With
sc = sc + 1
End If
Next c
End With
With ws
LastColumn = .Cells(14, Columns.count).End(xlToLeft).Column
.Range("B32").Formula = "=SUM(C32:INDEX(32:32,MATCH(9.99999999999999E+307,32:32)))"
.Range("B34").Formula = "=SUM(C34:INDEX(34:34,MATCH(9.99999999999999E+307,34:34)))"
.Range("B36").Formula = "=SUM(C36:INDEX(36:36,MATCH(9.99999999999999E+307,36:36)))"
.Range("B46").Formula = "=SUM(C46:INDEX(46:46,MATCH(9.99999999999999E+307,46:46)))"
.Range("B51").Formula = "=SUM(C51:INDEX(51:51,MATCH(9.99999999999999E+307,51:51)))"
.Range("B52").Formula = "=SUM(C52:INDEX(52:52,MATCH(9.99999999999999E+307,52:52)))"
.Range("B53").Formula = "=SUM(C53:INDEX(53:53,MATCH(9.99999999999999E+307,53:53)))"
.Range("B54").Formula = "=SUM(C54:INDEX(54:54,MATCH(9.99999999999999E+307,54:54)))"
.Range("B55").Formula = "=SUM(C55:INDEX(55:55,MATCH(9.99999999999999E+307,55:55)))"
.Range("B56").Formula = "=SUM(C56:INDEX(56:56,MATCH(9.99999999999999E+307,56:56)))"
.Range("B61").Formula = "=SUM(C61:INDEX(61:61,MATCH(9.99999999999999E+307,61:61)))"
.Range("B62").Formula = "=SUM(C62:INDEX(62:62,MATCH(9.99999999999999E+307,62:62)))"
.Range("B63").Formula = "=b62/b51"
.Range("B56").Formula = "=IF(OR(B46=""N/A"",B46=""""),""N/A"",IF(B46=0,0,B55/B46))"
.Range("B58").Formula = "=IF(B32=0,""N/A"",B51/B32)"
.Range("B59").Formula = "=IF(B34=0,""N/A"",B51/B34)"
.Range("B60").Formula = "=IF(B40=0,""N/A"",B51/B40)"
.Range(.Cells(46, 3), .Cells(46, LastColumn)) = "=C42*C44*VLOOKUP(C24,NamedRange,2,FALSE)"
.Range(.Cells(51, 3), .Cells(51, LastColumn)) = "=C42*C50*VLOOKUP(C24,NamedRange,2,FALSE)"
End With
With ws
Dim i As Long
For i = 2 To LastColumn
If .Cells(63, i) >= 0 And Not IsEmpty(Cells(63, i)) Then
.Cells(63, i).Interior.Color = 13434828
ElseIf .Cells(63, i) < 0 And Not IsEmpty(Cells(63, i)) Then
.Cells(63, i).Interior.Color = 255
End If
Next i
End With
With ws
With .Range(.Cells(63, 2), .Cells(63, LastColumn))
.FormatConditions.Add Type:=xlExpression, Formula1:="=B$63<0"
.FormatConditions(.FormatConditions.count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
.FormatConditions.Add Type:=xlExpression, Formula1:="=B$63>=0"
.FormatConditions(.FormatConditions.count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13434828
.TintAndShade = 0
End With
.FormatConditions(1).StopIfTrue = False
End With
End With
With ws
With .Range(.Cells(62, 2), .Cells(62, LastColumn))
.FormatConditions.Add Type:=xlExpression, Formula1:="=B$63<0"
.FormatConditions(.FormatConditions.count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
.FormatConditions.Add Type:=xlExpression, Formula1:="=B$63>=0."
.FormatConditions(.FormatConditions.count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13434828
.TintAndShade = 0
End With
.FormatConditions(1).StopIfTrue = False
End With
End With
With ws
With .Range(.Cells(61, 2), .Cells(61, LastColumn))
.FormatConditions.Add Type:=xlExpression, Formula1:="=B$63<0"
.FormatConditions(.FormatConditions.count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
.FormatConditions.Add Type:=xlExpression, Formula1:="=B$63>=0"
.FormatConditions(.FormatConditions.count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13434828
.TintAndShade = 0
End With
.FormatConditions(1).StopIfTrue = False
End With
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub