Here is what I've come up with so far. I'm sure the "special case" of the
begining of the year is not quite right. As well as, I'm sure there is a
more elegant solution that I cannot see.
Thanks for the help,
Chris
Code:
Sub GetGraphData()
Dim ThisWeek As Integer, ThisWeekCounter As Integer
Dim Week2 As Integer, Week2Counter As Integer
Dim Week3 As Integer, Week3Counter As Integer
Dim Week4 As Integer, Week4Counter As Integer
Dim Week5 As Integer, Week5Counter As Integer
Dim Week6 As Integer, Week6Counter As Integer
Dim Week7 As Integer, Week7Counter As Integer
Dim Week8 As Integer, Week8Counter As Integer
'Variables for special case
Dim CurrDate As Date
Dim offset As Integer
'initialize counters to zero
ThisWeekCounter = 0
Week2Counter = 0
Week3Counter = 0
Week4Counter = 0
Week5Counter = 0
Week6Counter = 0
Week7Counter = 0
Week8Counter = 0
'Get this week's week number
ThisWeek = VBAWeekNum(Now, 2) 'days begin on Monday and end on Sunday
If ThisWeek < 8 Then 'This is the begining of the year, special case
Dim rng As Range
Dim i As Integer
For i = 45 To LastCell(Worksheets(NewSheetname)).row
Set rng = Worksheets(NewSheetname).Cells(i, 2)
If ThisWeek < VBAWeekNum(rng.Value, 2) Then
Select Case True
Case 52 = VBAWeekNum(rng.Value, 2)
If rng.Interior.ColorIndex >= 0 And _
rng.Interior.ColorIndex < 57 Then
Week2Counter = Week2Counter + 1
End If
Case 52 - ThisWeek = VBAWeekNum(rng.Value, 2)
If rng.Interior.ColorIndex >= 0 And _
rng.Interior.ColorIndex < 57 Then
Week3Counter = Week3Counter + 1
End If
Case 52 - ThisWeek - 2 = VBAWeekNum(rng.Value, 2)
If rng.Interior.ColorIndex >= 0 And _
rng.Interior.ColorIndex < 57 Then
Week4Counter = Week4Counter + 1
End If
Case 52 - ThisWeek - 3 = VBAWeekNum(rng.Value, 2)
If rng.Interior.ColorIndex >= 0 And _
rng.Interior.ColorIndex < 57 Then
Week5Counter = Week5Counter + 1
End If
Case 52 - ThisWeek - 4 = VBAWeekNum(rng.Value, 2)
If rng.Interior.ColorIndex >= 0 And _
rng.Interior.ColorIndex < 57 Then
Week6Counter = Week6Counter + 1
End If
Case 52 - ThisWeek - 5 = VBAWeekNum(rng.Value, 2)
If rng.Interior.ColorIndex >= 0 And _
rng.Interior.ColorIndex < 57 Then
Week7Counter = Week7Counter + 1
End If
Case 52 - ThisWeek - 6 = VBAWeekNum(rng.Value, 2)
If rng.Interior.ColorIndex >= 0 And _
rng.Interior.ColorIndex < 57 Then
Week8Counter = Week8Counter + 1
End If
Case Else
End Select
Else
Select Case True
Case ThisWeek = VBAWeekNum(rng.Value, 2)
If rng.Interior.ColorIndex >= 0 And _
rng.Interior.ColorIndex < 57 Then
ThisWeekCounter = ThisWeekCounter + 1
CurrDate = rng.Value
End If
Case ThisWeek - 1 = VBAWeekNum(rng.Value, 2)
If rng.Interior.ColorIndex >= 0 And _
rng.Interior.ColorIndex < 57 Then
Week2Counter = Week2Counter + 1
CurrDate = rng.Value
End If
Case ThisWeek - 2 = VBAWeekNum(rng.Value, 2)
If rng.Interior.ColorIndex >= 0 And _
rng.Interior.ColorIndex < 57 Then
Week3Counter = Week3Counter + 1
CurrDate = rng.Value
End If
Case ThisWeek - 3 = VBAWeekNum(rng.Value, 2)
If rng.Interior.ColorIndex >= 0 And _
rng.Interior.ColorIndex < 57 Then
Week4Counter = Week4Counter + 1
CurrDate = rng.Value
End If
Case ThisWeek - 4 = VBAWeekNum(rng.Value, 2)
If rng.Interior.ColorIndex >= 0 And _
rng.Interior.ColorIndex < 57 Then
Week5Counter = Week5Counter + 1
CurrDate = rng.Value
End If
Case ThisWeek - 5 = VBAWeekNum(rng.Value, 2)
If rng.Interior.ColorIndex >= 0 And _
rng.Interior.ColorIndex < 57 Then
Week6Counter = Week6Counter + 1
CurrDate = rng.Value
End If
Case ThisWeek - 6 = VBAWeekNum(rng.Value, 2)
If rng.Interior.ColorIndex >= 0 And _
rng.Interior.ColorIndex < 57 Then
Week7Counter = Week7Counter + 1
CurrDate = rng.Value
End If
Case ThisWeek - 7 = VBAWeekNum(rng.Value, 2)
If rng.Interior.ColorIndex >= 0 And _
rng.Interior.ColorIndex < 57 Then
Week8Counter = Week8Counter + 1
CurrDate = rng.Value
End If
Case Else
End Select
End If
Next i
Else 'This is after week 8, handle as normal
Dim rng2 As Range
Dim j As Integer
For j = 45 To LastCell(Worksheets(NewSheetname)).row
Set rng2 = Worksheets(NewSheetname).Cells(j, 2)
Select Case True
Case ThisWeek = VBAWeekNum(rng2.Value, 2)
If rng2.Interior.ColorIndex >= 0 And _
rng2.Interior.ColorIndex < 57 Then
ThisWeekCounter = ThisWeekCounter + 1
End If
Case ThisWeek - 1 = VBAWeekNum(rng2.Value, 2)
If rng2.Interior.ColorIndex >= 0 And _
rng2.Interior.ColorIndex < 57 Then
Week2Counter = Week2Counter + 1
End If
Case ThisWeek - 2 = VBAWeekNum(rng2.Value, 2)
If rng2.Interior.ColorIndex >= 0 And _
rng2.Interior.ColorIndex < 57 Then
Week3Counter = Week3Counter + 1
End If
Case ThisWeek - 3 = VBAWeekNum(rng2.Value, 2)
If rng2.Interior.ColorIndex >= 0 And _
rng2.Interior.ColorIndex < 57 Then
Week4Counter = Week4Counter + 1
End If
Case ThisWeek - 4 = VBAWeekNum(rng2.Value, 2)
If rng2.Interior.ColorIndex >= 0 And _
rng2.Interior.ColorIndex < 57 Then
Week5Counter = Week5Counter + 1
End If
Case ThisWeek - 5 = VBAWeekNum(rng2.Value, 2)
If rng2.Interior.ColorIndex >= 0 And _
rng2.Interior.ColorIndex < 57 Then
Week6Counter = Week6Counter + 1
End If
Case ThisWeek - 6 = VBAWeekNum(rng2.Value, 2)
If rng2.Interior.ColorIndex >= 0 And _
rng2.Interior.ColorIndex < 57 Then
Week7Counter = Week7Counter + 1
End If
Case ThisWeek - 7 = VBAWeekNum(rng2.Value, 2)
If rng2.Interior.ColorIndex >= 0 And _
rng2.Interior.ColorIndex < 57 Then
Week8Counter = Week8Counter + 1
End If
Case Else
End Select
Next j
End If
Dim rng3 As Range
Set rng3 =
Worksheets(NewSheetname).Cells(LastCell(Worksheets(NewSheetname)).row, 1)
'Heading
rng3.offset(2, 2).Value = "Totals to be Charted"
rng3.offset(2, 2).Font.Bold = True
rng3.offset(2, 2).Font.Italic = True
rng3.offset(2, 2).Font.Underline = xlUnderlineStyleSingle
rng3.offset(2, 3).Value = "Violations"
rng3.offset(2, 3).Font.Bold = True
rng3.offset(2, 3).Font.Italic = True
rng3.offset(2, 3).Font.Underline = xlUnderlineStyleSingle
rng3.offset(3, 2).Value = "This Week"
rng3.offset(3, 3).Value = ThisWeekCounter
rng3.offset(4, 2).Value = "Week 2"
rng3.offset(4, 3).Value = Week2Counter
rng3.offset(5, 2).Value = "Week 3"
rng3.offset(5, 3).Value = Week3Counter
rng3.offset(6, 2).Value = "Week 4"
rng3.offset(6, 3).Value = Week4Counter
rng3.offset(7, 2).Value = "Week 5"
rng3.offset(7, 3).Value = Week5Counter
rng3.offset(8, 2).Value = "Week 6"
rng3.offset(8, 3).Value = Week6Counter
rng3.offset(9, 2).Value = "Week 7"
rng3.offset(9, 3).Value = Week7Counter
rng3.offset(10, 2).Value = "Week 8"
rng3.offset(10, 3).Value = Week8Counter
MakeChart "C" & rng3.offset(2, 3).row & ":" & "D" & rng3.offset(10,
4).row _
, NewSheetname
End Sub
Function VBAWeekNum(D As Date, FW As Integer) As Integer
VBAWeekNum = CInt(Format(D, "ww", FW))
End Function
Sub MakeChart(data As String, NewSheetname As String)
Charts.Add
ActiveChart.ChartType = xl3DColumnClustered
ActiveChart.SetSourceData Source:=Sheets(NewSheetname). _
Range(data), PlotBy:=xlColumns
ActiveChart.Location Where:=xlLocationAsObject, Name:=NewSheetname
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "Violations- Last 8 Weeks"
.Axes(xlCategory).HasTitle = False
.Axes(xlSeries).HasTitle = False
.Axes(xlValue).HasTitle = False
End With
With ActiveChart
.HasAxis(xlCategory) = True
.HasAxis(xlSeries) = False
.HasAxis(xlValue) = True
End With
ActiveChart.Axes(xlCategory).CategoryType = xlAutomatic
ActiveChart.HasLegend = False
ActiveChart.HasDataTable = True
ActiveSheet.Shapes(1).Left = Range("B1").Left
ActiveSheet.Shapes(1).Top = Range("B1").Top
ActiveSheet.Shapes(1).ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
ActiveSheet.Shapes(1).ScaleHeight 2.5, msoFalse, msoScaleFromTopLeft
End Sub
Function LastCell(ws As Worksheet) As Range
Dim LastRow&, LastCol%
' Error-handling is here in case there is not any
' data in the worksheet
On Error Resume Next
With ws
' Find the last real row
LastRow& = .Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).row
' Find the last real column
LastCol% = .Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns).Column
End With
' Finally, initialize a Range object variable for
' the last populated row.
Set LastCell = ws.Cells(LastRow&, LastCol%)
End Function
