D
davegb
I have a workbook where our specialists enter their activities by
alphanumeric code. (Some codes alpha, some numeric, none mixed). Each
specialist has 2 sheets in the workbook. One in which they report their
work, another that tallies the work by code and month and creates a
graph for them and others to look for trends, etc. The macro I've
written, with this NG's help, is run when a specialist's monthy tally
sheet is selected. The macro goes to the entry, or source, sheet, and
checks each cell in the specified range for certain codes. If it finds
an appropriate code, it checks another cell to see if it has a
recognizable date. If these criteria are met, it tallies the number of
times a giving code occurs in each month of the year. If the criteria
are not met, it skips to the next cell. One of the codes, 16, has
tallied subcodes as well (A, R, B, G). It all works fine.
I've been writing VBA macros for about 8 months now, and my progress
has been slow. I want to get better at this.
What I'm interested in is how to streamline the code, if possible. How
would someone do the same thing with less code? Speed is not important
in this application, no specialist has more than a 1000 entries. But
what if it were? How would you make this run even faster?
I'm particularly interested in better ways to do the subcodes. I've
marked this part of the macro.
I'd also appreciate feedback on formatting and comments. Any way to
make it easier to come back later and debug or change the code.
Thanks for any feedback.
Sub SpecMonthCount()
Dim lngRsnCode As Long 'Reason Code from source sheet
Dim wksSrc As Worksheet 'source worksheet, where specicalists enter
their counts
Dim wksSpecMon As Worksheet 'Monthly sheet, where the counts are
tallied by month
Dim wksTot As Worksheet 'TOTALS worksheet where the vlookup for tally
column & row is determined
Dim rngCode As Range 'range in which codes are stored
Dim lEndRow As Long 'no of rows to check for values
Dim strMonWksht As String 'current Monthly worksheet name
Dim dteColCode As Date 'date of contact taken from source sheet
Dim lngCntctMo As Long 'month taken from contact date
Dim lngMoRow As Long 'the appropriate row where that months tally is
entered
Dim rngCell As Range 'current cell from which reason code is taken
Dim varColCode As Variant 'date taken from Contact Date field
Dim strColCode As String 'column where current data is tallied
determined by vlookup in TOTALS sheet
Dim lCt As Long 'counter for subcategories of category 16 (CIR's, sub
cat A, B, G, R)
Dim rng16Code As Range 'starting point for entering cat 16 sub cats
Dim strSrc As String 'name of source sheet gotten by extracting from
selected montly sheet
Dim strSpecMon As String 'name of specialist's monthly sheet
Const PWORD As String = "2005totals"
lEndRow = 1000
Set wksSpecMon = ActiveSheet
Set wksTot = ActiveWorkbook.Sheets("TOTALS")
strSpecMon = wksSpecMon.Name
'Get source sheet name from monthly sheet name
strSrc = Left(strSpecMon, Len(strSpecMon) - 10)
Set wksSrc = Sheets(strSrc)
Set rngCode = wksSrc.Range("D8
" & lEndRow)
wksTot.Unprotect Password:=PWORD
wksSpecMon.Range("B4:K15").ClearContents
For Each rngCell In rngCode
dteColCode = 0
Select Case rngCell
Case 1, 14, 4, 13, 3, 7, 16
Set varColCode = rngCell.Offset(0, 5)
'if there's a comma in the code value, skip to the next cell
If InStr(1, varColCode, ",") = 0 Then
'if the code cell is blank, skip to the next cell
If Trim(varColCode.Value) <> "" Then
'if the code is not a date, procede to the next
step
On Error Resume Next
dteColCode = DateValue(varColCode.Value)
'reset error handling to default
On Error GoTo 0
'if the code cell is blank, skip to the next cell
If dteColCode <> Empty Then
'extract the month from the date field,
' add 3 to get the row to enter the count in
lngCntctMo = Month(dteColCode)
lngMoRow = lngCntctMo + 3
'enter the reason code into the Totals sheet
' and do a vlookup to get the column to enter the
code in
lngRsnCode = rngCell.Value
wksTot.Range("AC1") = lngRsnCode
strColCode = wksTot.Range("AC2")
wksSpecMon.Cells(lngMoRow, strColCode) = _
wksSpecMon.Cells(lngMoRow, strColCode) + 1
'test if cat 16
If rngCell = "16" Then <---SUBCODE PROCEDURE
START
'determine starting point for cat 16
sub cat tally
Set rng16Code =
wksSpecMon.Cells(lngMoRow, strColCode)
'tally cell if cat R
lCt = InStr(1, UCase(rngCell.Offset(0,
2).Value), "R")
If lCt > 0 Then
rng16Code.Offset(0, 1) = _
rng16Code.Offset(0, 1) + 1
lCt = 0
End If
lCt = InStr(1, UCase(rngCell.Offset(0,
2).Value), "A")
If lCt > 0 Then
rng16Code.Offset(0, 2) = _
rng16Code.Offset(0, 2) + 1
lCt = 0
End If
lCt = InStr(1, UCase(rngCell.Offset(0,
2).Value), "B")
If lCt > 0 Then
rng16Code.Offset(0, 3) = _
rng16Code.Offset(0, 3) + 1
Else
lCt = InStr(1, UCase(rngCell.Offset(0,
2).Value), "G")
If lCt > 0 Then
rng16Code.Offset(0, 3) = _
rng16Code.Offset(0, 3) + 1
lCt = 0
End If
End If <---SUBCODE PROCEDURE ENDS
End If
End If
End If
End If
End Select
Next rngCell
End Sub
alphanumeric code. (Some codes alpha, some numeric, none mixed). Each
specialist has 2 sheets in the workbook. One in which they report their
work, another that tallies the work by code and month and creates a
graph for them and others to look for trends, etc. The macro I've
written, with this NG's help, is run when a specialist's monthy tally
sheet is selected. The macro goes to the entry, or source, sheet, and
checks each cell in the specified range for certain codes. If it finds
an appropriate code, it checks another cell to see if it has a
recognizable date. If these criteria are met, it tallies the number of
times a giving code occurs in each month of the year. If the criteria
are not met, it skips to the next cell. One of the codes, 16, has
tallied subcodes as well (A, R, B, G). It all works fine.
I've been writing VBA macros for about 8 months now, and my progress
has been slow. I want to get better at this.
What I'm interested in is how to streamline the code, if possible. How
would someone do the same thing with less code? Speed is not important
in this application, no specialist has more than a 1000 entries. But
what if it were? How would you make this run even faster?
I'm particularly interested in better ways to do the subcodes. I've
marked this part of the macro.
I'd also appreciate feedback on formatting and comments. Any way to
make it easier to come back later and debug or change the code.
Thanks for any feedback.
Sub SpecMonthCount()
Dim lngRsnCode As Long 'Reason Code from source sheet
Dim wksSrc As Worksheet 'source worksheet, where specicalists enter
their counts
Dim wksSpecMon As Worksheet 'Monthly sheet, where the counts are
tallied by month
Dim wksTot As Worksheet 'TOTALS worksheet where the vlookup for tally
column & row is determined
Dim rngCode As Range 'range in which codes are stored
Dim lEndRow As Long 'no of rows to check for values
Dim strMonWksht As String 'current Monthly worksheet name
Dim dteColCode As Date 'date of contact taken from source sheet
Dim lngCntctMo As Long 'month taken from contact date
Dim lngMoRow As Long 'the appropriate row where that months tally is
entered
Dim rngCell As Range 'current cell from which reason code is taken
Dim varColCode As Variant 'date taken from Contact Date field
Dim strColCode As String 'column where current data is tallied
determined by vlookup in TOTALS sheet
Dim lCt As Long 'counter for subcategories of category 16 (CIR's, sub
cat A, B, G, R)
Dim rng16Code As Range 'starting point for entering cat 16 sub cats
Dim strSrc As String 'name of source sheet gotten by extracting from
selected montly sheet
Dim strSpecMon As String 'name of specialist's monthly sheet
Const PWORD As String = "2005totals"
lEndRow = 1000
Set wksSpecMon = ActiveSheet
Set wksTot = ActiveWorkbook.Sheets("TOTALS")
strSpecMon = wksSpecMon.Name
'Get source sheet name from monthly sheet name
strSrc = Left(strSpecMon, Len(strSpecMon) - 10)
Set wksSrc = Sheets(strSrc)
Set rngCode = wksSrc.Range("D8
" & lEndRow)wksTot.Unprotect Password:=PWORD
wksSpecMon.Range("B4:K15").ClearContents
For Each rngCell In rngCode
dteColCode = 0
Select Case rngCell
Case 1, 14, 4, 13, 3, 7, 16
Set varColCode = rngCell.Offset(0, 5)
'if there's a comma in the code value, skip to the next cell
If InStr(1, varColCode, ",") = 0 Then
'if the code cell is blank, skip to the next cell
If Trim(varColCode.Value) <> "" Then
'if the code is not a date, procede to the next
step
On Error Resume Next
dteColCode = DateValue(varColCode.Value)
'reset error handling to default
On Error GoTo 0
'if the code cell is blank, skip to the next cell
If dteColCode <> Empty Then
'extract the month from the date field,
' add 3 to get the row to enter the count in
lngCntctMo = Month(dteColCode)
lngMoRow = lngCntctMo + 3
'enter the reason code into the Totals sheet
' and do a vlookup to get the column to enter the
code in
lngRsnCode = rngCell.Value
wksTot.Range("AC1") = lngRsnCode
strColCode = wksTot.Range("AC2")
wksSpecMon.Cells(lngMoRow, strColCode) = _
wksSpecMon.Cells(lngMoRow, strColCode) + 1
'test if cat 16
If rngCell = "16" Then <---SUBCODE PROCEDURE
START
'determine starting point for cat 16
sub cat tally
Set rng16Code =
wksSpecMon.Cells(lngMoRow, strColCode)
'tally cell if cat R
lCt = InStr(1, UCase(rngCell.Offset(0,
2).Value), "R")
If lCt > 0 Then
rng16Code.Offset(0, 1) = _
rng16Code.Offset(0, 1) + 1
lCt = 0
End If
lCt = InStr(1, UCase(rngCell.Offset(0,
2).Value), "A")
If lCt > 0 Then
rng16Code.Offset(0, 2) = _
rng16Code.Offset(0, 2) + 1
lCt = 0
End If
lCt = InStr(1, UCase(rngCell.Offset(0,
2).Value), "B")
If lCt > 0 Then
rng16Code.Offset(0, 3) = _
rng16Code.Offset(0, 3) + 1
Else
lCt = InStr(1, UCase(rngCell.Offset(0,
2).Value), "G")
If lCt > 0 Then
rng16Code.Offset(0, 3) = _
rng16Code.Offset(0, 3) + 1
lCt = 0
End If
End If <---SUBCODE PROCEDURE ENDS
End If
End If
End If
End If
End Select
Next rngCell
End Sub