Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations Westi on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Advanced VBA errors, need guidance! 2

Status
Not open for further replies.

lespaul

Programmer
Feb 4, 2002
7,083
US
Hello all, I have a spreadsheet that Dale and others helped with, and I'm having to make changes and fix problems and Dale's no longer really "available". So hopefully one of you will be able to assist me.

I have a spreadsheet to which I export raw data (to the 'DATA' sheet). This information includes the name, address, etc, juror hours, juror payment due, juror mileage, juror mileage due.

I then have a macro that should clear any existing data on the 'Voucher Report' page, check that juror payment due + juror mileage due = 0 and if it does DELETE THAT ROW SO NO PAYMENT IS PROCESSED AND THE PERSON DOESN'T SHOW UP ON THE VOUCHER PAGE. As I have found previously, deleting a row can cause problems!

I thought I was making progress on the checking for zero value, but now, early code is failing! I would appreciate some guidance and help. I can email the spreadsheet if anyone can take a look at it for me!

Thanks!



Leslie
landrews@metrocourt.state.nm.us

There are 10 types of people in the world -
those who understand binary
and
those who don't!
 
Are you asking for something like this?

Assume 102 jurors listed...
Code:
Row1: headings
Row2: juror 001
Row3: juror 002
:
:
Row51: juror 050
Row52:  subtotal formulas for jurors 001 thru 050
Row53:  blank for aesthetic purposes
Row54: juror 051
Row55: juror 052
:
:
Row103: juror 100
Row104:  subtotal formulas for jurors 051 thru 100
Row105:  blank
Row106: juror 101
Row107: juror 102
Row108:  subtotal formulas for jurors 101 thru 102
Row109:  blank
Row110:  total formulas for jurors 001 thru 102
Set up print area for rows 2 thru 110
Set up to print row 1 at the top of every sheet
Set up top and bottom margins so that only 50 lines (+headings +totals) appear on a page.

If the answer is yes, then yes that should be possible.
 
Here is the macro code thru setting up subtotals and totals. You should be able to build the macro for the printing setup by yourself (use the macro recorder and then modify it as needed.)
Code:
Option Explicit

Sub Generate_VoucherRpt()
Dim nUsedRows As Long

  ' Clear target area
  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:F2").Copy Destination:=Range("A3:A" & nUsedRows)
  ' Pretty up with subtotals
  InsertSubtotals
  ' Terminate
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

Sub InsertSubtotals()
Const ROWS_PER_GROUP = 50
Const FIRST_COL = 2 ' Column "B"
Const LAST_COL = 6 ' Column "F"
Const SUMFORMULA = "=SUBTOTAL(9,R[-50]C:R[-1]C)"

Dim sLastSubtotalFormula As String
Dim sTotalFormula As String
Dim nRows As Long
Dim nLastGroupRows As Integer
Dim nGroups As Integer
Dim i As Integer
Dim nInsertionRow As Long
Dim rInsertionPoint As Range

  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, 0) = "  Subtotals"
      Range(.Offset(-2, FIRST_COL - 1), .Offset(-2, LAST_COL - 1)).FormulaR1C1 = SUMFORMULA
    End With
  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(-2, 0) = "     Totals"
    Range(.Offset(-2, FIRST_COL - 1), .Offset(-2, LAST_COL - 1)).FormulaR1C1 = sTotalFormula
  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
Be sure to use the VALUE( ) function for each of the formulas in the VoucherReport sheet data columns "B" thru "E."

 
Thanks!! I'll work on this today, but what is the Value() function and when do I use it??

Les
 
In an earlier post you wrote:
...
Code:
So my data worksheet is laid out as indicated above.  The VoucherReport has the following formula in the 2nd row:
A:  =Data!A2&CHAR(10)&"    "&Data!B2&CHAR(10)&"    "&Data!C2
B:  =Data!D2
C:  =ROUND(VALUE(Data!E2),2)
D:  =Data!F2
E:  =ROUND(VALUE(Data!G2),2)
F:  =C2+E2
...

I was merely trying to point out that the formulas in B2 and D2 also need to use the VALUE( ) function the way the formulas in C2 and E2 do. This is because you indicated that the data on the "Data" sheet may have leading or trailing spaces, so you should be consistent:
Code:
B2: =ROUND(VALUE(Data!D2),2)
D2: =ROUND(VALUE(Data!F2),2)
 
Ok, thanks!

Leslie
landrews@metrocourt.state.nm.us

There are 10 types of people in the world -
those who understand binary
and
those who don't!
 
Another modification!!! Hopefully it won't be too difficult to incorporate.

I need to include a "voucher number". I have inserted a page break in the Subtotals section so that each "section" prints separately. Each "section" will have a different voucher number. This number is actually text (example: 03-012-150138). The first group of 50 will have this number, the second group of 50 needs to be 03-012-150139, etc.

Can I pass this value from my Delphi program to the Excel macro and increment it there during each page break and then send back the last used to Delphi to update my storage area? Or should I create an array in Delphi to pass to the macro that has all the voucher numbers that will be needed for each section and place the values from there, which makes updating the storage area easier to do?

Hope this is clear and you can help me figure it out!!

I also wanted to be able to name the subtotal ranges so I can have a summary sheet that shows the subtotal of each voucher number.

Thanks!

leslie
 
You should be able to pass the initial voucher number and increment it as needed with this:
[blue]
Code:
Sub IncrementVoucherNumber(VoucherNumber As String)
[green]
Code:
' Assumes VoucherNumber format: nn-nnn-nnnnnn
[/color]
Code:
Dim nSerial As Long
  nSerial = Right(VoucherNumber, 6)
  VoucherNumber = Left(VoucherNumber, 7) & (nSerial + 1)
End Sub
[/color]

And it shouldn't be too hard at each rInsertionPoint to create a range name. Remember that rInsertionPoint is always a 1-cell range from which you can obtain .Row and .Column numbers to use in building up an expression to use as a range definition. (More practice with the macro recorder should give you what you need for deleting and creating range names.) Dim another variable to contain the range number (e.g. nSubTotalSequence) and make the names something like
"SUBTOTALRANGE" & nSubTotalSequence
 
You ROCK!!! I'll be working on this today!

Les
 
So I'm making progress! I have created a range named "lastvoucher" that is populated with my Delphi program with the last used voucher number. It increments just fine. I am now trying to print out each subtotal section with the correct voucher number on it. Since the first row repeats, I added a column that gets the current value of the "lastvoucher" range. Before I increment it I want to print the current section. So I am trying to set the print area in the Subtotal routine and I keep getting an error! "Unable to set the PrintArea property of the PageSetup class". I have included all the code below,

Thanks!
Leslie

Code:
Option Explicit

Sub Generate_VoucherRpt()
Dim nUsedRows As Long

  ' Clear target area
  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:F2").Copy Destination:=Range("A3:A" & nUsedRows)
  ' Pretty up with subtotals
  InsertSubtotals
  ' Terminate
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

Sub InsertSubtotals()
Const ROWS_PER_GROUP = 50
Const FIRST_COL = 2 ' Column "B"
Const LAST_COL = 6 ' Column "F"
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, 0) = "  Subtotals"
      Range(.Offset(-2, FIRST_COL - 1), .Offset(-2, LAST_COL - 1)).FormulaR1C1 = SUMFORMULA
      .Offset(-2, 0).EntireRow.Font.Bold = True
    End With
Code:
ActiveSheet.PageSetup.PrintArea = ActiveSheet.Range(Cells(nPrintRow, 1), Cells(nInsertionRow, 7))
Code:
ActiveSheet.PrintOut
    ActiveSheet.PageSetup.PrintArea = ""
    nPrintRow = nInsertionRow
    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
  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
 
I figured it out!! the Print area needs A1 notation it can't use the range notation I was using above!!

Worksheets("VoucherReport").PageSetup.PrintArea = "A" & CStr(nPrintRow) & ":H" & CStr(nInsertionRow)
 
Ok, I think I'm just about done with this!! One more thing, I have added in Column H the PK of the database. Once all the zero rows have been deleted, I need to insert a record for each of the numbers in column H. I was thinking I could loop through the columns and put the value of the remaining jurors into another cell in a comma delimited list which I could then transfer back to delphi and do an INSERT query where jurnum in (string from excel). How can I accomplish this?

Column H
4254
4350
4117
4218

Reference cell = 4254,4350,4117,4218

Thanks!

Leslie
 
That shouldn't be too difficult. A CSV list of numbers can easily be put into a TStringList which can then be used as a driver to insert data into the database. As a plan "B" you could write the jurnums into a file and load the TStringList from the file. AFAIK, you can't just do an INSERT where IN (list). The WHERE IN... construct only works for SELECT and UPDATE.

This function returns a csv list from the given range:
[blue]
Code:
Function CSVList(ARange As Range) As String
Dim c As Range
  For Each c In ARange
    If c.Text <> &quot;&quot; Then
      If CSVList = &quot;&quot; Then
        CSVList = c.Text
      Else
        CSVList = CSVList + &quot;,&quot; + c.Text
      End If
    End If
  Next c
End Function
[/color]


Just use the function in your worksheet like any Excel function:
[blue]
Code:
  =CSVLIST(H2:H275)
[/color]

 
Ok, that works like a charm. Now I'm having problems getting the information into my TStringList. Here's what I have so far (amidst my other code):

PaidJurorList : TStrings;

PaidJurorList := TStringList.Create;
PaidJurorList.Add(excelapp.Worksheets.Item['Criteria'].Range['jurorlist']);

where the range juror list is created with the CSVList function.

Apparently Add doesn't work for comma delimited. I looked at LoadFromFile but I don't think I really need to create a text file if I can get the information from the already open Excel file.

Thanks for all your help. It's really nice to have a guru who knows the two languages that I use most of the time. Thanks again!

Leslie
 
The property you are looking for is TStrings.CommaText
[blue]
Code:
PaidJurorList.CommaText := excelapp.Worksheets.Item['Criteria'].Range['jurorlist'];
[/color]

Glad to help. Just don't call me for jury duty! [smile]
 
As far as I'm concerned, you are permanently exempt from jury duty at our courthouse (can't do anything abouth any where else though!)

Thanks again,
leslie
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top