I have a spread sheet that Dale123321 helped develop. It takes raw data from my Delphi application and prints a report for our accounting department to use for paying jurors. I now have to add a line number to the report and since Dale's coding skills in Excel far exceed mine, I would like a little assistance in creating and adding this function.
The report takes the raw data and reviews it for people who are not getting any payment and then removes them. Then it copies all the remaining information from the Data Sheet to the Voucher Report Sheet. Then for each group of 50 it adds a subtotal section and for the last group (which may have 1 - 50 members) it adds the subtotal. I was thinking of adding a LineNumber function to the subtotal function that would number each line in the subtotal group from 1 - 50 (or in the case of the last group 1 - whatever).
Here is all the existing code (some of it relevant to this problem and some not), if you can help and would like to see the entire spreadsheet, please email and I'll be happy to send it to you.
(I emailed Dale to get his help first, but he's out of the office until early August and I can't wait that long!!).
Leslie
landrews@metrocourt.state.nm.us
There are 10 types of people in the world -
those who understand binary
and
those who don't!
The report takes the raw data and reviews it for people who are not getting any payment and then removes them. Then it copies all the remaining information from the Data Sheet to the Voucher Report Sheet. Then for each group of 50 it adds a subtotal section and for the last group (which may have 1 - 50 members) it adds the subtotal. I was thinking of adding a LineNumber function to the subtotal function that would number each line in the subtotal group from 1 - 50 (or in the case of the last group 1 - whatever).
Here is all the existing code (some of it relevant to this problem and some not), if you can help and would like to see the entire spreadsheet, please email and I'll be happy to send it to you.
(I emailed Dale to get his help first, but he's out of the office until early August and I can't wait that long!!).
Code:
Option Explicit
Sub Generate_VoucherRpt()
Dim nUsedRows As Long
' Clear target area
IncrementVoucherNumber (Worksheets("Data").Range("VoucherNumber"))
Worksheets("VoucherReport").Activate
Worksheets("VoucherReport").Range("A3:F65536").EntireRow.Delete
Application.ScreenUpdating = False
Worksheets("Data").Activate
' Eliminate zero-value rows
DeleteZeroRows Intersect(ActiveSheet.UsedRange, Range("A2:G65536"))
' Copy formulas from row 2 as far as needed
nUsedRows = ActiveSheet.UsedRange.Rows.Count
Worksheets("VoucherReport").Activate
Range("A2:G2").Copy Destination:=Range("A3:A" & nUsedRows)
' Pretty up with subtotals
InsertSubtotals
' Terminate
Worksheets("Criteria").Range("jurorlist").Formula = "= CSVLIST(Data!H2:H275)"
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Sub InsertSubtotals()
Const ROWS_PER_GROUP = 50
Const FIRST_COL = 3 ' Column "C"
Const LAST_COL = 7 ' Column "G"
Const SUMFORMULA = "=SUBTOTAL(9,R[-50]C:R[-1]C)"
Dim sLastSubtotalFormula As String
Dim sTotalFormula As String
Dim nRows As Long
Dim nPrintRow As Long
Dim nLastGroupRows As Integer
Dim nGroups As Integer
Dim i As Integer
Dim nInsertionRow As Long
Dim rInsertionPoint As Range
nPrintRow = 2
nRows = ActiveSheet.UsedRange.Rows.Count - 1
nGroups = Int((nRows - 1) / ROWS_PER_GROUP) + 1
' Loop thru all groups but the last:
For i = 1 To nGroups - 1
nInsertionRow = i * ROWS_PER_GROUP + i * 2
Set rInsertionPoint = Cells(nInsertionRow, 1)
With rInsertionPoint
.EntireRow.Insert Shift:=xlDown
.EntireRow.Insert Shift:=xlDown
.Offset(-2, 1) = " Subtotals"
Range(.Offset(-2, FIRST_COL - 1), .Offset(-2, LAST_COL - 1)).FormulaR1C1 = SUMFORMULA
.Offset(-2, 0).EntireRow.Font.Bold = True
End With
Worksheets("VoucherReport").PageSetup.PrintArea = "A" & CStr(nPrintRow) & ":H" & CStr(nInsertionRow)
'Worksheets("VoucherReport").PrintOut Copies:=1, Collate:=True
ActiveSheet.PageSetup.PrintArea = ""
nPrintRow = nInsertionRow + 2
IncrementVoucherNumber (Worksheets("Data").Range("VoucherNumber"))
Next i
' Do last group
nInsertionRow = nGroups * 2 + nRows
nLastGroupRows = nRows - ((nGroups - 1) * ROWS_PER_GROUP)
Set rInsertionPoint = Cells(nInsertionRow, 1)
sLastSubtotalFormula = "=SUBTOTAL(9,R[-" & nLastGroupRows & "]C:R[-1]C)"
sTotalFormula = "=SUBTOTAL(9,R[-" & nInsertionRow & "]C:R[-1]C)"
With rInsertionPoint
.EntireRow.Insert Shift:=xlDown
.EntireRow.Insert Shift:=xlDown
.EntireRow.Insert Shift:=xlDown
.EntireRow.Insert Shift:=xlDown
.Offset(-4, 0) = " Subtotals"
Range(.Offset(-4, FIRST_COL - 1), .Offset(-4, LAST_COL - 1)).FormulaR1C1 = sLastSubtotalFormula
.Offset(-4, 0).EntireRow.Font.Bold = True
.Offset(-2, 0) = " Totals"
Range(.Offset(-2, FIRST_COL - 1), .Offset(-2, LAST_COL - 1)).FormulaR1C1 = sTotalFormula
.Offset(-2, 0).EntireRow.Font.Bold = True
Worksheets("VoucherReport").PageSetup.PrintArea = "A" & CStr(nPrintRow) & ":H" & CStr(nInsertionRow)
'Worksheets("VoucherReport").PrintOut Copies:=1, Collate:=True
ActiveSheet.PageSetup.PrintArea = ""
End With
Set rInsertionPoint = Nothing
End Sub
Function DeleteZeroRows(ARange As Range) As Long
Dim rWorkingRange As Range
Dim rTestRange As Range
Dim nCountDeletes As Long
Dim nFirstRow As Long
Dim nLastRow As Long
Dim nFirstCol As Integer
Dim nLastCol As Integer
Dim nRow As Long
Dim nNewLastRow As Long
Set rWorkingRange = ARange
nFirstRow = rWorkingRange.Row
nLastRow = rWorkingRange.Rows.Count + nFirstRow - 1
nFirstCol = rWorkingRange.Column
nLastCol = rWorkingRange.Columns.Count + nFirstCol - 1
'Scan rows and delete where all zero
For nRow = nLastRow To nFirstRow Step -1
Set rTestRange = Range(Cells(nRow, nFirstCol), Cells(nRow, nLastCol))
If SumText(rTestRange) = 0 Then
rTestRange.EntireRow.Delete
nCountDeletes = nCountDeletes + 1
End If
Next nRow
'Wrap it up
DeleteZeroRows = nCountDeletes
Set rTestRange = Nothing
Set rWorkingRange = Nothing
End Function
Function SumText(ARange As Range) As Double
Dim c As Range
For Each c In ARange
If IsNumeric(c.Text) Then
SumText = SumText + c.Text
End If
Next c
End Function
Sub IncrementVoucherNumber(VoucherNumber As String)
' Assumes VoucherNumber format: nn-nnn-nnnnnn
Dim nSerial As Long
nSerial = Right(VoucherNumber, 6)
VoucherNumber = Left(VoucherNumber, 7) & (nSerial + 1)
Worksheets("Data").Range("VoucherNumber") = VoucherNumber
End Sub
Function CSVList(ARange As Range) As String
Dim c As Range
For Each c In ARange
If c.Text <> "" Then
If CSVList = "" Then
CSVList = c.Text
Else
CSVList = CSVList + "," + c.Text
End If
End If
Next c
End FunctionLeslie
landrews@metrocourt.state.nm.us
There are 10 types of people in the world -
those who understand binary
and
those who don't!
, just add one to a counter as you go and poke the counter into the cell. when the counter gets to 50, set it back to zero.