Printing

[Hmmm...]

Hi,

I have a rush job for a church auction and I'm hoping someone can give me a
snippet of VB code that will show me what to do.

The auction items are in a worksheet. Each row contains the information for
an auction item. One of the columns is the Buyer ID. The Buyer ID
identifies the winner of each auction item. The worksheet will be sorted by
Buyer ID.

I want to run a macro that will print the auction items for each buyer. I
imagine a loop that will start at the top and print the auction items for
each buyer. Each buyer should have a separate printout.

Any ideas or examples? Thanks.

 

[Leo Heuser]

Here's one way. The IDs don't have to be sorted.

Sub AuctionPrintOut()
'Leo Heuser, 23 Apr. 2004
Dim Cell As Range
Dim Counter As Long
Dim HeadingRows As Long
Dim ID As Variant
Dim IDCollection As New Collection
Dim IDRange As Range
Dim IDRangeValue As Variant
Dim IDStartCell As String
Dim SheetName As String

SheetName = "Sheet1"
IDStartCell = "D2"
HeadingRows = 1 'Number of heading rows at the top

With Sheets(SheetName)
Set IDRange = Range(Range(IDStartCell), .Cells(.Rows.Count, _
.Range(IDStartCell).Column).End(xlUp))

IDRangeValue = IDRange.Value

On Error Resume Next

For Each ID In IDRangeValue
IDCollection.Add Item:=ID, key:=CStr(ID)
Next ID

For Counter = 1 To IDCollection.Count
.Rows.Hidden = True
.Rows("1:" & HeadingRows).Hidden = False
For Each Cell In IDRange.Cells
If Cell.Value = IDCollection(Counter) Then
Cell.EntireRow.Hidden = False
End If
Next Cell

.PrintOut
Next Counter

.Rows.Hidden = False
End With
End Sub

 

[Hmmm...]

Thanks! It works!

Now I have a couple questions about a small enhancement. In the

For Each Cell In IDRange.Cells
If Cell.Value = IDCollection(Counter) Then

section, is it possible to access a neighboring "amount" cell, so that I can
tally up a subtotal for each ID? Also, it it possible to determine whether
the current cell is the last one in the range? Thanks.

 

[Leo Heuser]

You're welcome, Hmmm

Try this one instead.
It is assumed that data starts in row 2 and row 1
contains headings. Set FilterField so it matches
your setup.

LastIdRow will contain the last row for each ID.


Sub AuctionPrintOut()
'Leo Heuser, 24 Apr. 2004
Dim AmountRange As Range
Dim AmountStartCell As String
Dim Counter As Long
Dim FilterField As Long
Dim ID As Variant
Dim IDCollection As New Collection
Dim IDRange As Range
Dim IDRangeValue As Variant
Dim IDStartCell As String
Dim LastIdRow As Long
Dim SheetName As String
Dim SubTotalCell As Range
Dim VisibleCells As Range

SheetName = "Sheet1"
IDStartCell = "D2"
AmountStartCell = "F2"
FilterField = 4 'Assuming first column is A and ID in column D

With Sheets(SheetName)
Set IDRange = Range(Range(IDStartCell), .Cells(.Rows.Count, _
.Range(IDStartCell).Column).End(xlUp))

IDRangeValue = IDRange.Value

Set AmountRange = IDRange. _
Offset(0, Range(AmountStartCell).Column - _
Range(IDStartCell).Column)

Set SubTotalCell = .Cells(AmountRange.Row + _
AmountRange.Rows.Count, Range(AmountStartCell).Column)

On Error Resume Next

For Each ID In IDRangeValue
IDCollection.Add Item:=ID, key:=CStr(ID)
Next ID

For Counter = 1 To IDCollection.Count
IDRange.Cells(1, 1).AutoFilter field:=FilterField, _
Criteria1:=IDCollection(Counter)

Set VisibleCells = IDRange.SpecialCells(xlCellTypeVisible)

With VisibleCells
LastIdRow = .Areas(.Areas.Count).Row + _
.Areas(.Areas.Count).Rows.Count - 1
End With

SubTotalCell.Formula = _
"=Subtotal(9," & AmountRange.Address & ")"

.PrintOut

SubTotalCell.ClearContents
Next Counter

.ShowAllData
.AutoFilterMode = False
End With
End Sub

 

[Wei-Dong XU [MSFT]]

Hi,

From my understanding to your questions, you are going to perform one summarization of each Buyer ID and decide whether the cell is in the last
row.

[I assume the worksheet as below:]
A B
1 Buyer ID value
2 12 2
3 23 34
4 34 2
5 5 234
6 6 2
7 6 234
8 7 2
9 7 234
10 34 2
11 23 45
12 12 2
13 5 234

1. sum each buyer ID value
'--Code begin -----------------------------------
Sub subtotal()
Dim oSht As Worksheet
Dim oWorkingRange, cell As Range
Dim oArray()
Dim subtotal As Integer

Set oSht = ActiveSheet
oArray = Array(0)
'specify the range
Set oWorkingRange = oSht.Range("A2:A13")

For Each cell In oWorkingRange.Cells
If Not CheckWhetherExisting(oArray, cell.value) Then
subtotal = 0
Call InputNewValuetoArray(oArray, cell.value)
Call sum(subtotal, cell.value, oWorkingRange)
End If
Next
End Sub

Sub sum(ByRef total As Integer, value, oRange)
Dim cell As Range
For Each cell In oRange.Cells
If cell.value = value Then
'sum the value
total = total + Range(CStr("b" & cell.Row)).value
End If
Next

'output the result for each ID
Debug.Print "ID:" & value & " Total:" & total

End Sub

Function IncreaseArrayByOne(oArray)
ReDim Preserve oArray(UBound(oArray) + 1)
IncreaseArrayByOne = oArray
End Function

Sub InputNewValuetoArray(ByRef oArray, value)
oArray = IncreaseArrayByOne(oArray)
oArray(UBound(oArray)) = CStr(value)
End Sub

Function CheckWhetherExisting(oArray, value)
If UBound(oArray) <> 0 Then
Dim boundary
boundary = UBound(oArray)
For i = 1 To boundary
If oArray(i) = CStr(value) Then
CheckWhetherExisting = True
Exit Function
End If
Next

Else
CheckWhetherExisting = False
End If
End Function
'--Code end ------------------------------------

2. check whether the cell is the last one in the column
We can use the UsedRange property to obtain the used range object. Then we can obtain the cells count in the Range. We can check whether
the row of the cell is equal to the one of the last cell in the used Range.
'--Code start ------------------------------------
Sub ValidateLastCell()

Dim oSht As Worksheet
Dim oAdr As String
Dim cellsCount, lastRow As Integer
Set oSht = ActiveSheet
cellsCount = oSht.UsedRange.Cells.Count
lastRow = oSht.UsedRange.Cells(cellsCount).Row

If lastRow = cell.Row Then
'Perform the operation according to your scenario
End If

End Sub
'--Code end -------------------------------------

Please feel free to let me know if you have any further questions.

Best Regards,
Wei-Dong Xu
Microsoft Product Support Services
Get Secure! - www.microsoft.com/security
This posting is provided "AS IS" with no warranties, and confers no rights.