But couldn't you have participants that meet the criterion on some worksheets,
but not on other worksheets?
So they could be paid up for class #1, but in the rears for class #7?
If I were doing this for myself, I'd put all the data for all the classes in one
giant worksheet.
The stuff that sounds like it should be common would appear once:
B7:b20 = Participant Names
C7:C20 = Member (Yes or No)
D7
20 = Phone Numbers
F7:F20 = Email
But the stuff that could change would have dedicated columns per
class/worksheet:
H7:H20 = Discount given
I7:I20 = Amount Owed (Calculated by cost of class - discount given)
J7:J20 = Amt. Paid
K7:K20 = Amt. Still Due (Amt. Owed - Amt. Paid)
L7:L20 = Signed Use Agreement Date
B2 = Date
Then by having all the data in one worksheet, I could add any formula that I
want (count all the amount still due, count the signed aggreement fields). Then
I could filter by those columns to get my individual reports (and I'd hide any
columns that I didn't want to see before I printed).
Here's where it gets ugly! Some of the offsets are hardcoded or depend on the
number of fields that go into each category--a lot of those offsets were trial
and error to get it in the right spot!
Option Explicit
Sub testme02()
Dim newWks As Worksheet
Dim wks As Worksheet
Dim curWkbk As Workbook
Dim myNameAddr As String
Dim myDateAddr As String
Dim wksCtr As Long
Dim res As Variant
Dim RngToInspect As Range
Dim myCell As Range
Dim destCell As Range
Dim iCol As Long
Dim TotalClasses As Long
Dim myHeaders() As String
Dim iCtr As Long
Dim myDetails As Variant
Dim VariableColumns As Variant
myNameAddr = "B7:B20"
myDateAddr = "B2"
myDetails = Array("Discount", "Owed", "Paid", "Due", "Date Signed", "Date")
Set curWkbk = ActiveWorkbook
TotalClasses = curWkbk.Worksheets.Count
ReDim myHeaders(0 To TotalClasses - 1)
iCtr = 0
For Each wks In curWkbk.Worksheets
myHeaders(iCtr) = wks.Name
iCtr = iCtr + 1
Next wks
VariableColumns = Array("h", "i", "j", "k", "l")
Set newWks = Workbooks.Add(1).Worksheets(1)
With newWks
.Range("a2:d2").Value _
= Array("Name", "Member", "Phone", "Email")
'0 to 5 for columns HIJKL & B2 make 6 columns
For iCtr = LBound(myDetails) To UBound(myDetails)
.Cells(1, 5 + iCtr * TotalClasses).Resize(1, TotalClasses).Value _
= myDetails(iCtr)
.Cells(2, 5 + iCtr * TotalClasses).Resize(1, TotalClasses).Value _
= myHeaders
Next iCtr
End With
wksCtr = 0
For Each wks In curWkbk.Worksheets
'columns B, C, D, F get copied once.
wksCtr = wksCtr + 1
Set RngToInspect = wks.Range(myNameAddr)
If wksCtr = 1 Then
newWks.Range("a3").Resize(RngToInspect.Rows.Count, 1).Value _
= wks.Range(myNameAddr).Value
newWks.Range("B3").Resize(RngToInspect.Rows.Count, 1).Value _
= wks.Range(myNameAddr).Offset(0, 1).Value
newWks.Range("c3").Resize(RngToInspect.Rows.Count, 1).Value _
= wks.Range(myNameAddr).Offset(0, 2).Value
newWks.Range("d3").Resize(RngToInspect.Rows.Count, 1).Value _
= wks.Range(myNameAddr).Offset(0, 4).Value
End If
'columns h, i, j, k, l, and B2 get copied always
For Each myCell In RngToInspect.Cells
If Trim(myCell.Value) = "" Then
'do nothing
Else
res = Application.Match(myCell.Value, _
newWks.Range("a:a"), 0)
If IsError(res) Then
'new name
With newWks
Set destCell = .Cells(.Rows.Count, "A") _
.End(xlUp).Offset(1, 0)
End With
'move in non-variable stuff
destCell.Value = myCell.Value
destCell.Offset(0, 1).Value = myCell.Offset(0, 1).Value
destCell.Offset(0, 2).Value = myCell.Offset(0, 2).Value
'skip a column
destCell.Offset(0, 3).Value = myCell.Offset(0, 4).Value
Else
Set destCell = newWks.Range("a:a")(res)
End If
'move date from B2
newWks.Cells(destCell.Row, _
wksCtr - 1 + 5 + 5 * TotalClasses).Value _
= wks.Range(myDateAddr)
For iCtr = LBound(VariableColumns) To UBound(VariableColumns)
newWks.Cells(destCell.Row, _
(wksCtr - 1) + 5 + (iCtr * TotalClasses)).Value _
= wks.Cells(myCell.Row, VariableColumns(iCtr)).Value
Next iCtr
End If
Next myCell
Next wks
With newWks
.Range(.Cells(1, 5 + 4 * TotalClasses), _
.Cells.SpecialCells(xlCellTypeLastCell)).EntireColumn.NumberFormat _
= "mm/dd/yyyy"
.UsedRange.Columns.AutoFit
.Range("a2", .Cells.SpecialCells(xlCellTypeLastCell)).Sort _
key1:=.Range("a2"), order1:=xlAscending, header:=xlYes
End With
End Sub
After running this macro, I'd insert a few columns that you could filter on
later:
=counta(yourrangehere)
would give the number of cells with values (like signatures)
=if(countif(yourrangehere,">0")=0,"all paid","still owe some")
for determining if people still owe.
==========
By putting the data in one worksheet, things should become easier!
