Sub Statistics_Create()
Dim sht As Worksheet
Dim Content_sht As Worksheet
Dim myArray As Variant
Dim x As Long, y As Long
Dim shtName1 As String, shtName2 As String
Dim ContentName As String
'Inputs
ContentName = "Statistics"
'Optimize Code
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Delete Contents Sheet if it already exists
On Error Resume Next
Worksheets("Statistics").Activate
On Error GoTo 0
If ActiveSheet.Name = ContentName Then
myAnswer = MsgBox("A worksheet named [" & ContentName & _
"] has already been created, would you like to replace it?", vbYesNo)
'Did user select No or Cancel?
If myAnswer <> vbYes Then GoTo ExitSub
'Delete old Contents Tab
Worksheets(ContentName).Delete
End If
'Create New Contents Sheet
Worksheets.Add Before:=Worksheets(1)
'Set variable to Contents Sheet
Set Content_sht = ActiveSheet
'Format Contents Sheet
With Content_sht
.Name = ContentName
Columns("A:A").Select
Selection.NumberFormat = "000-00-0000"
Columns("B:B").Select
Selection.NumberFormat = "m/d/yy;@"
Columns("C:C").Select
Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
Columns("D:D").Select
Selection.NumberFormat = "General"
Columns("E:E").Select
Selection.NumberFormat = "0.00"
Columns("F:F").Select
Selection.NumberFormat = "General"
Columns("G:G").Select
Selection.NumberFormat = "General"
Range("A1").Select
ActiveCell.FormulaR1C1 = "SID"
Range("B1").Select
ActiveCell.FormulaR1C1 = "DATE"
Range("C1").Select
ActiveCell.FormulaR1C1 = "TIME"
Range("D1").Select
ActiveCell.FormulaR1C1 = "SUBJECT"
Range("E1").Select
ActiveCell.FormulaR1C1 = "# OF VISITS"
Range("F1").Select
ActiveCell.FormulaR1C1 = "CAMPUS"
Range("G1").Select
ActiveCell.FormulaR1C1 = "PROGRAM"
Range("A1:G1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15773696
End With
Selection.Font.Bold = True
With Selection.Font
.Name = "Arial"
.Size = 14
.ColorIndex = xlAutomatic
End With
Columns("A:G").Select
Selection.ColumnWidth = 16
Range("A1:G1").Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
'Create Array list with SID Numbers, Dates and Values
ReDim myArray(1 To Worksheets.Count - 1)
Dim Rng As Range
Dim Cells As Integer
Set Rng = Range("D9:BC83")
If Not Rng Is Nothing Then
For Each sht In ActiveWorkbook.Worksheets
If sht.Name <> ContentName Then
For Each cell In Rng.Cells
If cell.Value <> "" Then
myArray(x + 1, 1) = sht.Cells(cell.Row, "C") And myArray(x + 2, 2) = sht.Cells(8, cell.Column) And myArray(x + 2, 3) = sht.Cells(cell.Value) And myArray(x + 2, 4) = sht.Cells("B2") And myArray(x + 2, 6) = sht.Cells("B6") And myArray(x + 2, 7) = sht.Cells("B7")
x = x + 1
End If
'Create Statistics
For x = LBound(myArray) To UBound(myArray)
Set sht = Worksheets(myArray(x))
sht.Activate
With Content_sht
Range("A1") = Format(SSN, "NNN-NN-NNNN")
Range("B1") = Format(date_test, "mm/dd/yy")
' Column 5: Displays the number of visits using a countif function
.Cells(x + 2, 5).FormulaR1C1 = "=COUNTIF(C[-4],RC[-4])"
' Find the last filled row in column E
Range("D3:E3").AutoFill Range("D3:E" & Range("E2").End(xlDown).Row)
End With
Content_sht.Activate
Content_sht.Columns(3).EntireColumn.AutoFit
'Adjust Zoom and Remove Gridlines
ActiveWindow.DisplayGridlines = True
ActiveWindow.Zoom = 100
ExitSub:
'Optimize Code
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub