copy multiple records based on criteria or total amount

i changed the code, i am getting the following error, compile error Expected:
End of statement and the entire new line turns red.

and how can i fix the 2nd problem?

"Joel" wrote:

I thought about this problem last night and found a simple solution. A a
number infront of each sheet name. I used RowCount which will be unique for
each award. I sutracted 1 since RowCount starts with 2.

change this line
shtname = (RowCount - 1) & " : " MinAward & " - " & MaxAward


There is a 2nd problem with the code that you need to fix. Having more than
1 award in a range means you have to prevent the same contract from being
awarded twice.

"David" wrote:

I just realized the problem, however i dont know how to fix it, I have the
following in awards sheet

% Min Max
5% 0 5000
30% 0 5000
10% 0 5000
9% 0 5000
6% 0 5000

since it cant create the 2nd sheet with the same name, its giving me that
error
"Joel" wrote:

After diner I decided to make some improvements

1) I forgot to increment RowCount. The oriignal code will only do one row
in the award table

2) I changed the criteria for each range. It was possible for the same
contract to appear in two ranges

previous code had equals in both criteria in the statement below

.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="" & MaxAward

3) I seperated the code into two sub's. The first automatically calls the
2nd. It is easier to understand the code this way

4) I improved the algorithm for getting 5% of the total contracts in a
range. New code will get closer to the 5% amount.

Sub MakeBuckets()

Const AmountCol As String = "C"
Const TempShtName As String = "Temporary"


Dim percent As Single

Application.DisplayAlerts = False

'Delete all worksheets except Awards and Contracts
For ShtCount = Sheets.Count To 1 Step -1
If Sheets(ShtCount).Name "Awards" And _
Sheets(ShtCount).Name "Contracts" Then

Sheets(ShtCount).Delete
End If
Next ShtCount

'create temporary sheet for making buckets
Set tmpsht = Sheets.Add(after:=Sheets(Sheets.Count))
tmpsht.Name = TempShtName

With Sheets("Awards")
'get each bucket
RowCount = 2
Do While .Range("A" & RowCount) ""
percent = .Range("A" & RowCount)
MinAward = .Range("B" & RowCount)
MaxAward = .Range("C" & RowCount)

With Sheets("Contracts")
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
With .Columns(AmountCol & ":" & AmountCol)
.AutoFilter
End With


.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="" & MaxAward

With Sheets(TempShtName)
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
'clear temporary sheet
.Cells.ClearContents
End With

'copy filtered data to temporary sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=Sheets(TempShtName).Cells

End With

Call GetContracts(TempShtName, percent, AmountCol)

'create Award sheet sheet for making buckets
shtname = MinAward & " - " & MaxAward

Set AwardSht = Sheets.Add(after:=Sheets(Sheets.Count))
AwardSht.Name = shtname

'copy filtered data to Award sheet
Sheets(TempShtName).Cells.SpecialCells(Type:=xlCel lTypeVisible).Copy _
Destination:=AwardSht.Cells

'remove column IV from the Award sheet
AwardSht.Columns("IV").Delete

RowCount = RowCount + 1
Loop
End With

With Sheets("Contracts")
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With

Application.DisplayAlerts = False

End Sub
Sub GetContracts(shtname As String, percent As Single, AmountCol As String)

'sub routine to get a percentage of the contracts in a range
'filter the worksheet
'main routine will copy the filtered data

With Sheets(shtname)

'sort contracts highest to lowest
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
.Rows("1:" & LastRow).Sort _
key1:=.Range(AmountCol & "1"), _
order1:=xlDescending


'Get Grand Total for range
RangeTotal = Evaluate("Sum(" & AmountCol & "2:" & AmountCol & LastRow &
")")
Awards = RangeTotal * percent

Total = 0
'put an X in column IV for every contract that keeps total under Awards
For RowCount = 2 To LastRow
Amount = .Range(AmountCol & RowCount)
If Amount + Total = Awards Then
.Range("IV" & RowCount) = "X"
Total = Total + Amount
End If
Next RowCount

'filter on formula in column IV
With .Columns("IV:IV")
.AutoFilter
End With


.Range("IV2:IV" & LastRow).AutoFilter _
Field:=1, _
Criteria1:="X"

End With

End Sub


"Joel" wrote:

This is complicated but lets try to get it to work.

1) Name the worksheet with all the contract "Contracts" or change code below

2) Change this line of code below to specify which column has the dollar
amount of each contract

Const AmountCol = "C"

3) Create a new worksheet called Awards

Col A Col B Col C
Row 1 Award Percent Min Max
Row 2 5% 5000 10000

This worksheet can have as many rows as required. This sheet will determine
the range sizes.


4) I made the range size 5% of the total. You said 3000 contracts. Which
has priority the 5% or 3000 contracts? I sorted the contracts in descending
order and then selected the largest amounts until the max was exceeded. The
algorithm to get the best fit is complicated. The greeks 2000 years ago
tried to solve this problem. There is a whole branch of mathematics call
"packing problems" that is devoted to this type problem.

I can improve this portion of the program later after we get the basics
working.


Sub MakeBuckets()

Const AmountCol = "C"

Application.DisplayAlerts = False

'Delete all worksheets except Awards and Contracts
For ShtCount = Sheets.Count To 1 Step -1
If Sheets(ShtCount).Name "Awards" And _
Sheets(ShtCount).Name "Contracts" Then

Sheets(ShtCount).Delete
End If
Next ShtCount

'create temporary sheet for making buckets
Set tmpsht = Sheets.Add(after:=Sheets(Sheets.Count))
tmpsht.Name = "Temporary"

With Sheets("Awards")
'get each bucket
RowCount = 2
Percent = .Range("A" & RowCount)
MinAward = .Range("B" & RowCount)
MaxAward = .Range("C" & RowCount)

With Sheets("Contracts")
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
With .Columns(AmountCol & ":" & AmountCol)
.AutoFilter
End With


.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="=" & MaxAward

With Sheets("Temporary")
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
'clear temporary sheet
.Cells.ClearContents
End With

'copy filtered data to temporary sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=Sheets("Temporary").Cells

End With

With Sheets("Temporary")

'sort contracts highest to lowest
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
.Rows("1:" & LastRow).Sort _
key1:=.Range(AmountCol & "1"), _
order1:=xlDescending

'put totals in column IV
.Range("IV2").Formula = "=Sum(" & AmountCol & "$2:" & AmountCol & "2)"
'copy formula down worksheet
.Range("IV2").Copy _
Destination:=.Range("IV2:IV" & LastRow)

'Get Grand Total for range
RangeTotal = .Range("IV" & LastRow)
Awards = RangeTotal * Percent

'filter on formula in column IV
With .Columns("IV:IV")
.AutoFilter

I had a typo in my last posting

shtname = (RowCount - 1) & " - " & MinAward & " - " & MaxAward

A colon can't be used in a sheet name.

Also I found the evaluate statement need to include the sheet name otherwise
it might refer to the wrong sheet

'Get Grand Total for range
RangeTotal = Evaluate( _
"Sum(" & shtname & "!" & AmountCol & "2:" & AmountCol & LastRow & ")")
Awards = RangeTotal * percent




"David" wrote:

I just realized the problem, however i dont know how to fix it, I have the
following in awards sheet

% Min Max
5% 0 5000
30% 0 5000
10% 0 5000
9% 0 5000
6% 0 5000

since it cant create the 2nd sheet with the same name, its giving me that
error
"Joel" wrote:

After diner I decided to make some improvements

1) I forgot to increment RowCount. The oriignal code will only do one row
in the award table

2) I changed the criteria for each range. It was possible for the same
contract to appear in two ranges

previous code had equals in both criteria in the statement below

.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="" & MaxAward

3) I seperated the code into two sub's. The first automatically calls the
2nd. It is easier to understand the code this way

4) I improved the algorithm for getting 5% of the total contracts in a
range. New code will get closer to the 5% amount.

Sub MakeBuckets()

Const AmountCol As String = "C"
Const TempShtName As String = "Temporary"


Dim percent As Single

Application.DisplayAlerts = False

'Delete all worksheets except Awards and Contracts
For ShtCount = Sheets.Count To 1 Step -1
If Sheets(ShtCount).Name "Awards" And _
Sheets(ShtCount).Name "Contracts" Then

Sheets(ShtCount).Delete
End If
Next ShtCount

'create temporary sheet for making buckets
Set tmpsht = Sheets.Add(after:=Sheets(Sheets.Count))
tmpsht.Name = TempShtName

With Sheets("Awards")
'get each bucket
RowCount = 2
Do While .Range("A" & RowCount) ""
percent = .Range("A" & RowCount)
MinAward = .Range("B" & RowCount)
MaxAward = .Range("C" & RowCount)

With Sheets("Contracts")
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
With .Columns(AmountCol & ":" & AmountCol)
.AutoFilter
End With


.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="" & MaxAward

With Sheets(TempShtName)
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
'clear temporary sheet
.Cells.ClearContents
End With

'copy filtered data to temporary sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=Sheets(TempShtName).Cells

End With

Call GetContracts(TempShtName, percent, AmountCol)

'create Award sheet sheet for making buckets
shtname = MinAward & " - " & MaxAward

Set AwardSht = Sheets.Add(after:=Sheets(Sheets.Count))
AwardSht.Name = shtname

'copy filtered data to Award sheet
Sheets(TempShtName).Cells.SpecialCells(Type:=xlCel lTypeVisible).Copy _
Destination:=AwardSht.Cells

'remove column IV from the Award sheet
AwardSht.Columns("IV").Delete

RowCount = RowCount + 1
Loop
End With

With Sheets("Contracts")
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With

Application.DisplayAlerts = False

End Sub
Sub GetContracts(shtname As String, percent As Single, AmountCol As String)

'sub routine to get a percentage of the contracts in a range
'filter the worksheet
'main routine will copy the filtered data

With Sheets(shtname)

'sort contracts highest to lowest
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
.Rows("1:" & LastRow).Sort _
key1:=.Range(AmountCol & "1"), _
order1:=xlDescending


'Get Grand Total for range
RangeTotal = Evaluate("Sum(" & AmountCol & "2:" & AmountCol & LastRow &
")")
Awards = RangeTotal * percent

Total = 0
'put an X in column IV for every contract that keeps total under Awards
For RowCount = 2 To LastRow
Amount = .Range(AmountCol & RowCount)
If Amount + Total = Awards Then
.Range("IV" & RowCount) = "X"
Total = Total + Amount
End If
Next RowCount

'filter on formula in column IV
With .Columns("IV:IV")
.AutoFilter
End With


.Range("IV2:IV" & LastRow).AutoFilter _
Field:=1, _
Criteria1:="X"

End With

End Sub


"Joel" wrote:

This is complicated but lets try to get it to work.

1) Name the worksheet with all the contract "Contracts" or change code below

2) Change this line of code below to specify which column has the dollar
amount of each contract

Const AmountCol = "C"

3) Create a new worksheet called Awards

Col A Col B Col C
Row 1 Award Percent Min Max
Row 2 5% 5000 10000

This worksheet can have as many rows as required. This sheet will determine
the range sizes.


4) I made the range size 5% of the total. You said 3000 contracts. Which
has priority the 5% or 3000 contracts? I sorted the contracts in descending
order and then selected the largest amounts until the max was exceeded. The
algorithm to get the best fit is complicated. The greeks 2000 years ago
tried to solve this problem. There is a whole branch of mathematics call
"packing problems" that is devoted to this type problem.

I can improve this portion of the program later after we get the basics
working.


Sub MakeBuckets()

Const AmountCol = "C"

Application.DisplayAlerts = False

'Delete all worksheets except Awards and Contracts
For ShtCount = Sheets.Count To 1 Step -1
If Sheets(ShtCount).Name "Awards" And _
Sheets(ShtCount).Name "Contracts" Then

Sheets(ShtCount).Delete
End If
Next ShtCount

'create temporary sheet for making buckets
Set tmpsht = Sheets.Add(after:=Sheets(Sheets.Count))
tmpsht.Name = "Temporary"

With Sheets("Awards")
'get each bucket
RowCount = 2
Percent = .Range("A" & RowCount)
MinAward = .Range("B" & RowCount)
MaxAward = .Range("C" & RowCount)

With Sheets("Contracts")
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
With .Columns(AmountCol & ":" & AmountCol)
.AutoFilter
End With


.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="=" & MaxAward

With Sheets("Temporary")
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
'clear temporary sheet
.Cells.ClearContents
End With

'copy filtered data to temporary sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=Sheets("Temporary").Cells

End With

With Sheets("Temporary")

'sort contracts highest to lowest
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
.Rows("1:" & LastRow).Sort _
key1:=.Range(AmountCol & "1"), _
order1:=xlDescending

'put totals in column IV
.Range("IV2").Formula = "=Sum(" & AmountCol & "$2:" & AmountCol & "2)"
'copy formula down worksheet
.Range("IV2").Copy _
Destination:=.Range("IV2:IV" & LastRow)

'Get Grand Total for range
RangeTotal = .Range("IV" & LastRow)
Awards = RangeTotal * Percent

'filter on formula in column IV
With .Columns("IV:IV")
.AutoFilter
End With


.Range("IV2:IV" & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & Awards


'create Award sheet sheet for making buckets
ShtName = MinAward & " - " & MaxAward

Set AwardSht = Sheets.Add(after:=Sheets(Sheets.Count))
AwardSht.Name = ShtName

Hi Joel,

great now it creates multiple sheets for each, however there are 2 problems

1. when it copies to other sheets, it doubles every single records
for example if there is a record with 20.00 it will copy and paste the
same record twice
2. it awards the same records into each buckets, which you mentioned before
as well.

"Joel" wrote:

I had a typo in my last posting

shtname = (RowCount - 1) & " - " & MinAward & " - " & MaxAward

A colon can't be used in a sheet name.

Also I found the evaluate statement need to include the sheet name otherwise
it might refer to the wrong sheet

'Get Grand Total for range
RangeTotal = Evaluate( _
"Sum(" & shtname & "!" & AmountCol & "2:" & AmountCol & LastRow & ")")
Awards = RangeTotal * percent




"David" wrote:

I just realized the problem, however i dont know how to fix it, I have the
following in awards sheet

% Min Max
5% 0 5000
30% 0 5000
10% 0 5000
9% 0 5000
6% 0 5000

since it cant create the 2nd sheet with the same name, its giving me that
error
"Joel" wrote:

After diner I decided to make some improvements

1) I forgot to increment RowCount. The oriignal code will only do one row
in the award table

2) I changed the criteria for each range. It was possible for the same
contract to appear in two ranges

previous code had equals in both criteria in the statement below

.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="" & MaxAward

3) I seperated the code into two sub's. The first automatically calls the
2nd. It is easier to understand the code this way

4) I improved the algorithm for getting 5% of the total contracts in a
range. New code will get closer to the 5% amount.

Sub MakeBuckets()

Const AmountCol As String = "C"
Const TempShtName As String = "Temporary"


Dim percent As Single

Application.DisplayAlerts = False

'Delete all worksheets except Awards and Contracts
For ShtCount = Sheets.Count To 1 Step -1
If Sheets(ShtCount).Name "Awards" And _
Sheets(ShtCount).Name "Contracts" Then

Sheets(ShtCount).Delete
End If
Next ShtCount

'create temporary sheet for making buckets
Set tmpsht = Sheets.Add(after:=Sheets(Sheets.Count))
tmpsht.Name = TempShtName

With Sheets("Awards")
'get each bucket
RowCount = 2
Do While .Range("A" & RowCount) ""
percent = .Range("A" & RowCount)
MinAward = .Range("B" & RowCount)
MaxAward = .Range("C" & RowCount)

With Sheets("Contracts")
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
With .Columns(AmountCol & ":" & AmountCol)
.AutoFilter
End With


.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="" & MaxAward

With Sheets(TempShtName)
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
'clear temporary sheet
.Cells.ClearContents
End With

'copy filtered data to temporary sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=Sheets(TempShtName).Cells

End With

Call GetContracts(TempShtName, percent, AmountCol)

'create Award sheet sheet for making buckets
shtname = MinAward & " - " & MaxAward

Set AwardSht = Sheets.Add(after:=Sheets(Sheets.Count))
AwardSht.Name = shtname

'copy filtered data to Award sheet
Sheets(TempShtName).Cells.SpecialCells(Type:=xlCel lTypeVisible).Copy _
Destination:=AwardSht.Cells

'remove column IV from the Award sheet
AwardSht.Columns("IV").Delete

RowCount = RowCount + 1
Loop
End With

With Sheets("Contracts")
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With

Application.DisplayAlerts = False

End Sub
Sub GetContracts(shtname As String, percent As Single, AmountCol As String)

'sub routine to get a percentage of the contracts in a range
'filter the worksheet
'main routine will copy the filtered data

With Sheets(shtname)

'sort contracts highest to lowest
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
.Rows("1:" & LastRow).Sort _
key1:=.Range(AmountCol & "1"), _
order1:=xlDescending


'Get Grand Total for range
RangeTotal = Evaluate("Sum(" & AmountCol & "2:" & AmountCol & LastRow &
")")
Awards = RangeTotal * percent

Total = 0
'put an X in column IV for every contract that keeps total under Awards
For RowCount = 2 To LastRow
Amount = .Range(AmountCol & RowCount)
If Amount + Total = Awards Then
.Range("IV" & RowCount) = "X"
Total = Total + Amount
End If
Next RowCount

'filter on formula in column IV
With .Columns("IV:IV")
.AutoFilter
End With


.Range("IV2:IV" & LastRow).AutoFilter _
Field:=1, _
Criteria1:="X"

End With

End Sub


"Joel" wrote:

This is complicated but lets try to get it to work.

1) Name the worksheet with all the contract "Contracts" or change code below

2) Change this line of code below to specify which column has the dollar
amount of each contract

Const AmountCol = "C"

3) Create a new worksheet called Awards

Col A Col B Col C
Row 1 Award Percent Min Max
Row 2 5% 5000 10000

This worksheet can have as many rows as required. This sheet will determine
the range sizes.


4) I made the range size 5% of the total. You said 3000 contracts. Which
has priority the 5% or 3000 contracts? I sorted the contracts in descending
order and then selected the largest amounts until the max was exceeded. The
algorithm to get the best fit is complicated. The greeks 2000 years ago
tried to solve this problem. There is a whole branch of mathematics call
"packing problems" that is devoted to this type problem.

I can improve this portion of the program later after we get the basics
working.


Sub MakeBuckets()

Const AmountCol = "C"

Application.DisplayAlerts = False

'Delete all worksheets except Awards and Contracts
For ShtCount = Sheets.Count To 1 Step -1
If Sheets(ShtCount).Name "Awards" And _
Sheets(ShtCount).Name "Contracts" Then

Sheets(ShtCount).Delete
End If
Next ShtCount

'create temporary sheet for making buckets
Set tmpsht = Sheets.Add(after:=Sheets(Sheets.Count))
tmpsht.Name = "Temporary"

With Sheets("Awards")
'get each bucket
RowCount = 2
Percent = .Range("A" & RowCount)
MinAward = .Range("B" & RowCount)
MaxAward = .Range("C" & RowCount)

With Sheets("Contracts")
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
With .Columns(AmountCol & ":" & AmountCol)
.AutoFilter
End With


.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="=" & MaxAward

With Sheets("Temporary")
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
'clear temporary sheet
.Cells.ClearContents
End With

'copy filtered data to temporary sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=Sheets("Temporary").Cells

End With

With Sheets("Temporary")

'sort contracts highest to lowest
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
.Rows("1:" & LastRow).Sort _
key1:=.Range(AmountCol & "1"), _
order1:=xlDescending

'put totals in column IV
.Range("IV2").Formula = "=Sum(" & AmountCol & "$2:" & AmountCol & "2)"
'copy formula down worksheet
.Range("IV2").Copy _
Destination:=.Range("IV2:IV" & LastRow)

'Get Grand Total for range
RangeTotal = .Range("IV" & LastRow)

Remeber to change the column letter where the amounts are located

I made a lot of changes and improvements to the code.

The three main thing I changed are the following

1) I now test in the award table if adjacent rows have the same min and max
amounts. Make sure you always keep the same ranges together in this table.
I only filter and copy the range once from the contract sheet to the
temporary sheet.

2) The temporary sheet I initially put an X in column IV when a contract is
assigned. Then filter on the X and copy the x's to a new worksheet. Then I
replace the X with an A (awarded). The next award in the same range I skip
the A's so I don't award the contract more than once.

3) I put a summary row for each new worksheet that contains the expected
award , the actual award, the total for the range, and the actual award.

Sub MakeBuckets()

Const AmountCol As String = "C"
Const TempShtName As String = "Temporary"

Dim percent As Single
Dim RangeTotal As Single

Set AwardSht = Sheets("Awards")
Set ContractSht = Sheets("Contracts")

Application.DisplayAlerts = False

'Delete all worksheets except Awards and Contracts
For ShtCount = Sheets.Count To 1 Step -1
If Sheets(ShtCount).Name "Awards" And _
Sheets(ShtCount).Name "Contracts" Then

Sheets(ShtCount).Delete
End If
Next ShtCount

'create temporary sheet for making buckets
Set Tmpsht = Sheets.Add(after:=Sheets(Sheets.Count))
Tmpsht.Name = TempShtName

With AwardSht
'get each bucket
RowCount = 2
Do While .Range("A" & RowCount) ""

With Tmpsht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With

percent = .Range("A" & RowCount)
MinAward = .Range("B" & RowCount)
MaxAward = .Range("C" & RowCount)

'only copy award range once if there are multiple
'awards in the same range
If MinAward .Range("B" & (RowCount - 1)) Or _
MaxAward .Range("C" & (RowCount - 1)) Then

With ContractSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
With .Columns(AmountCol & ":" & AmountCol)
.AutoFilter
End With


.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="" & MaxAward

'clear temporary sheet
Tmpsht.Cells.ClearContents

'copy filtered data to temporary sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=Tmpsht.Cells


'sort contracts highest to lowest
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
.Rows("1:" & LastRow).Sort _
key1:=.Range(AmountCol & "1"), _
order1:=xlDescending

End With

End If

Call GetContracts(TempShtName, percent, AmountCol, RangeTotal)

'create Range sheet sheet for making buckets
shtname = "(" & (RowCount - 1) & ") " & MinAward & " - " & MaxAward

Set RangeSht = Sheets.Add(after:=Sheets(Sheets.Count))
RangeSht.Name = shtname

With Tmpsht

'copy filtered data to Award sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=RangeSht.Cells

'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With


With RangeSht
'remove column IV from the Award sheet
.Columns("IV").Delete

'Get Last row
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
SummaryRow = LastRow + 2
'put formula total columns
.Range(AmountCol & SummaryRow).Offset(0, -1) = "Total Awards"
.Range(AmountCol & SummaryRow).Offset(0, 0).Formula = _
"=SUM(" & AmountCol & "2:" & AmountCol & LastRow & ")"
Total = .Range(AmountCol & SummaryRow).Offset(0, 0)
.Range(AmountCol & SummaryRow).Offset(1, -1) = "Total Range"
.Range(AmountCol & SummaryRow).Offset(1, 0) = RangeTotal
.Range(AmountCol & SummaryRow).Offset(2, -1) = "Expected Award"
.Range(AmountCol & SummaryRow).Offset(2, 0) = RangeTotal * percent
.Range(AmountCol & SummaryRow).Offset(3, -1) = "Expected Percent"
.Range(AmountCol & SummaryRow).Offset(3, 0) = percent
.Range(AmountCol & SummaryRow).Offset(4, -1) = "Actual Percent"
.Range(AmountCol & SummaryRow).Offset(4, 0) = Total / (RangeTotal)

.Columns.AutoFit
End With

RowCount = RowCount + 1
Loop
End With

With ContractSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With

Application.DisplayAlerts = False

End Sub
Sub GetContracts(shtname As String, percent As Single, AmountCol As String, _
ByRef RangeTotal As Single)

'sub routine to get a percentage of the contracts in a range
'filter the worksheet
'main routine will copy the filtered data

With Sheets(shtname)
'replace any awarded contract with an X in column IV with A (awarded)
'this is so the same contract doesn't get awarded twice
.Columns("IV").Replace _
What:="X", _
Replacement:="A", _
LookAt:=xlWhole


LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row

'Get Grand Total for range
RangeTotal = Evaluate( _
"Sum(" & shtname & "!" & AmountCol & "2:" & AmountCol & LastRow & ")")
Awards = RangeTotal * percent

Total = 0
'put an X in column IV for every contract that keeps total under Awards
For RowCount = 2 To LastRow
'test if contract already awareded
If .Range("IV" & RowCount) "A" Then
Amount = .Range(AmountCol & RowCount)
If Amount + Total = Awards Then
.Range("IV" & RowCount) = "X"
Total = Total + Amount
End If
End If
Next RowCount

'check if ther is filtered data
Cellsnotempty = Evaluate("Counta(" & shtname & "!IV:IV)")

If Cellsnotempty 0 Then

'filter on formula in column IV
With .Columns("IV:IV")
.AutoFilter
End With


.Range("IV2:IV" & LastRow).AutoFilter _
Field:=1, _
Criteria1:="X"
End If

End With


End Sub






"David" wrote:

Hi Joel,

great now it creates multiple sheets for each, however there are 2 problems

1. when it copies to other sheets, it doubles every single records
for example if there is a record with 20.00 it will copy and paste the
same record twice
2. it awards the same records into each buckets, which you mentioned before
as well.

"Joel" wrote:

I had a typo in my last posting

shtname = (RowCount - 1) & " - " & MinAward & " - " & MaxAward

A colon can't be used in a sheet name.

Also I found the evaluate statement need to include the sheet name otherwise
it might refer to the wrong sheet

'Get Grand Total for range
RangeTotal = Evaluate( _
"Sum(" & shtname & "!" & AmountCol & "2:" & AmountCol & LastRow & ")")
Awards = RangeTotal * percent




"David" wrote:

I just realized the problem, however i dont know how to fix it, I have the
following in awards sheet

% Min Max
5% 0 5000
30% 0 5000
10% 0 5000
9% 0 5000
6% 0 5000

since it cant create the 2nd sheet with the same name, its giving me that
error
"Joel" wrote:

After diner I decided to make some improvements

1) I forgot to increment RowCount. The oriignal code will only do one row
in the award table

2) I changed the criteria for each range. It was possible for the same
contract to appear in two ranges

previous code had equals in both criteria in the statement below

.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="" & MaxAward

3) I seperated the code into two sub's. The first automatically calls the
2nd. It is easier to understand the code this way

4) I improved the algorithm for getting 5% of the total contracts in a
range. New code will get closer to the 5% amount.

Sub MakeBuckets()

Const AmountCol As String = "C"
Const TempShtName As String = "Temporary"


Dim percent As Single

Application.DisplayAlerts = False

'Delete all worksheets except Awards and Contracts
For ShtCount = Sheets.Count To 1 Step -1
If Sheets(ShtCount).Name "Awards" And _
Sheets(ShtCount).Name "Contracts" Then

Sheets(ShtCount).Delete
End If
Next ShtCount

'create temporary sheet for making buckets
Set tmpsht = Sheets.Add(after:=Sheets(Sheets.Count))
tmpsht.Name = TempShtName

With Sheets("Awards")
'get each bucket
RowCount = 2
Do While .Range("A" & RowCount) ""
percent = .Range("A" & RowCount)
MinAward = .Range("B" & RowCount)
MaxAward = .Range("C" & RowCount)

With Sheets("Contracts")
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
With .Columns(AmountCol & ":" & AmountCol)
.AutoFilter
End With


.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="" & MaxAward

With Sheets(TempShtName)
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
'clear temporary sheet
.Cells.ClearContents
End With

'copy filtered data to temporary sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=Sheets(TempShtName).Cells

End With

Call GetContracts(TempShtName, percent, AmountCol)

'create Award sheet sheet for making buckets
shtname = MinAward & " - " & MaxAward

Set AwardSht = Sheets.Add(after:=Sheets(Sheets.Count))
AwardSht.Name = shtname

'copy filtered data to Award sheet
Sheets(TempShtName).Cells.SpecialCells(Type:=xlCel lTypeVisible).Copy _
Destination:=AwardSht.Cells

'remove column IV from the Award sheet
AwardSht.Columns("IV").Delete

RowCount = RowCount + 1
Loop
End With

With Sheets("Contracts")
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With

Application.DisplayAlerts = False

End Sub
Sub GetContracts(shtname As String, percent As Single, AmountCol As String)

'sub routine to get a percentage of the contracts in a range
'filter the worksheet
'main routine will copy the filtered data

With Sheets(shtname)

'sort contracts highest to lowest
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
.Rows("1:" & LastRow).Sort _
key1:=.Range(AmountCol & "1"), _
order1:=xlDescending


'Get Grand Total for range
RangeTotal = Evaluate("Sum(" & AmountCol & "2:" & AmountCol & LastRow &
")")
Awards = RangeTotal * percent

Total = 0
'put an X in column IV for every contract that keeps total under Awards
For RowCount = 2 To LastRow
Amount = .Range(AmountCol & RowCount)
If Amount + Total = Awards Then
.Range("IV" & RowCount) = "X"
Total = Total + Amount
End If
Next RowCount

'filter on formula in column IV
With .Columns("IV:IV")
.AutoFilter
End With


.Range("IV2:IV" & LastRow).AutoFilter _
Field:=1, _
Criteria1:="X"

End With

End Sub


"Joel" wrote:

This is complicated but lets try to get it to work.

1) Name the worksheet with all the contract "Contracts" or change code below

2) Change this line of code below to specify which column has the dollar
amount of each contract

Const AmountCol = "C"

3) Create a new worksheet called Awards

Col A Col B Col C
Row 1 Award Percent Min Max
Row 2 5% 5000 10000

This worksheet can have as many rows as required. This sheet will determine
the range sizes.


4) I made the range size 5% of the total. You said 3000 contracts. Which
has priority the 5% or 3000 contracts? I sorted the contracts in descending
order and then selected the largest amounts until the max was exceeded. The
algorithm to get the best fit is complicated. The greeks 2000 years ago
tried to solve this problem. There is a whole branch of mathematics call
"packing problems" that is devoted to this type problem.

I can improve this portion of the program later after we get the basics
working.


Sub MakeBuckets()

Const AmountCol = "C"

Application.DisplayAlerts = False

'Delete all worksheets except Awards and Contracts
For ShtCount = Sheets.Count To 1 Step -1
If Sheets(ShtCount).Name "Awards" And _
Sheets(ShtCount).Name "Contracts" Then

Sheets(ShtCount).Delete
End If
Next ShtCount

'create temporary sheet for making buckets
Set tmpsht = Sheets.Add(after:=Sheets(Sheets.Count))
tmpsht.Name = "Temporary"

With Sheets("Awards")
'get each bucket
RowCount = 2
Percent = .Range("A" & RowCount)
MinAward = .Range("B" & RowCount)
MaxAward = .Range("C" & RowCount)

With Sheets("Contracts")
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
With .Columns(AmountCol & ":" & AmountCol)
.AutoFilter
End With


.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="=" & MaxAward

With Sheets("Temporary")
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
'clear temporary sheet
.Cells.ClearContents
End With

'copy filtered data to temporary sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=Sheets("Temporary").Cells

End With

With Sheets("Temporary")

'sort contracts highest to lowest
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row

I wanted to put the award information for each row back into the Award
worksheet.

Here are the changes

Sub MakeBuckets()

Const AmountCol As String = "C"
Const TempShtName As String = "Temporary"

Dim percent As Single
Dim RangeTotal As Single

Set AwardSht = Sheets("Awards")
Set ContractSht = Sheets("Contracts")

Application.DisplayAlerts = False

'Delete all worksheets except Awards and Contracts
For ShtCount = Sheets.Count To 1 Step -1
If Sheets(ShtCount).Name "Awards" And _
Sheets(ShtCount).Name "Contracts" Then

Sheets(ShtCount).Delete
End If
Next ShtCount

'create temporary sheet for making buckets
Set Tmpsht = Sheets.Add(after:=Sheets(Sheets.Count))
Tmpsht.Name = TempShtName

With AwardSht
'add header row info
.Range("A1") = "%"
.Range("B1") = "Min"
.Range("C1") = "Max"
.Range("D1") = "Range Total"
.Range("E1") = "Expected Award"
.Range("F1") = "Actual Award"
.Range("G1") = "Actual %"

'get each bucket
RowCount = 2
Do While .Range("A" & RowCount) ""

With Tmpsht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With

percent = .Range("A" & RowCount)
MinAward = .Range("B" & RowCount)
MaxAward = .Range("C" & RowCount)

'only copy award range once if there are multiple
'awards in the same range
If MinAward .Range("B" & (RowCount - 1)) Or _
MaxAward .Range("C" & (RowCount - 1)) Then

With ContractSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
With .Columns(AmountCol & ":" & AmountCol)
.AutoFilter
End With


.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="" & MaxAward

'clear temporary sheet
Tmpsht.Cells.ClearContents

'copy filtered data to temporary sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=Tmpsht.Cells


'sort contracts highest to lowest
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
.Rows("1:" & LastRow).Sort _
key1:=.Range(AmountCol & "1"), _
order1:=xlDescending


'Get Grand Total for range
RangeTotal = Evaluate( _
"Sum(" & TempShtName & "!" & AmountCol & "2:" & _
AmountCol & LastRow & ")")

End With

End If

Award = RangeTotal * percent
Call GetContracts(TempShtName, AmountCol, Award)

'create Range sheet sheet for making buckets
shtname = "(" & (RowCount - 1) & ") " & MinAward & " - " & MaxAward

Set RangeSht = Sheets.Add(after:=Sheets(Sheets.Count))
RangeSht.Name = shtname

With Tmpsht

'copy filtered data to Award sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=RangeSht.Cells

End With


With RangeSht
'remove column IV from the Award sheet
.Columns("IV").Delete

'Get Last row
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
SummaryRow = LastRow + 2
'put formula total columns
.Range(AmountCol & SummaryRow).Offset(0, -1) = "Total Awards"
.Range(AmountCol & SummaryRow).Offset(0, 0).Formula = _
"=SUM(" & AmountCol & "2:" & AmountCol & LastRow & ")"
Total = .Range(AmountCol & SummaryRow).Offset(0, 0)
.Range(AmountCol & SummaryRow).Offset(1, -1) = "Total Range"
.Range(AmountCol & SummaryRow).Offset(1, 0) = RangeTotal
.Range(AmountCol & SummaryRow).Offset(2, -1) = "Expected Award"
.Range(AmountCol & SummaryRow).Offset(2, 0) = RangeTotal * percent
.Range(AmountCol & SummaryRow).Offset(3, -1) = "Expected Percent"
.Range(AmountCol & SummaryRow).Offset(3, 0) = percent
.Range(AmountCol & SummaryRow).Offset(4, -1) = "Actual Percent"
.Range(AmountCol & SummaryRow).Offset(4, 0) = Total / RangeTotal

.Columns.AutoFit
End With

With AwardSht
.Range("D" & RowCount) = RangeTotal
.Range("E" & RowCount) = RangeTotal * percent
.Range("F" & RowCount) = Total
.Range("G" & RowCount) = Total / RangeTotal
End With

RowCount = RowCount + 1
Loop
End With

With ContractSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With

With AwardSht
.Columns.AutoFit
End With

Application.DisplayAlerts = False

End Sub
Sub GetContracts(ByVal shtname As String, ByVal AmountCol As String, _
ByVal Award As Single)

'sub routine to get a percentage of the contracts in a range
'filter the worksheet
'main routine will copy the filtered data

With Sheets(shtname)
'replace any awarded contract with an X in column IV with A (awarded)
'this is so the same contract doesn't get awarded twice
.Columns("IV").Replace _
What:="X", _
Replacement:="A", _
LookAt:=xlWhole


LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row


Total = 0
'put an X in column IV for every contract that keeps total under Awards
For RowCount = 2 To LastRow
'test if contract already awareded
If .Range("IV" & RowCount) "A" Then
Amount = .Range(AmountCol & RowCount)
If Amount + Total = Award Then
.Range("IV" & RowCount) = "X"
Total = Total + Amount
End If
End If
Next RowCount

'check if ther is filtered data
Cellsnotempty = Evaluate("Counta(" & shtname & "!IV:IV)")

If Cellsnotempty 0 Then

'filter on formula in column IV
With .Columns("IV:IV")
.AutoFilter
End With


.Range("IV2:IV" & LastRow).AutoFilter _
Field:=1, _
Criteria1:="X"
End If

End With


End Sub

Hi Joel,

I cant thank you enough, it works like a charm, however one last thing, let
me know if i am asking for too much i will stop here,

is there away that it can get me list of the contracts that it was not able
to distribute to the buckets, for example in the first bucket it found
contracts totaling 50,000.00. Based on the distribution schedule it was able
to distribute only 49000.00 in total to different buckets. in a seperate
sheet can it get me the list of contracts that make up the remaining 1000.00,
so i can distribute it manually to the buckets?

"Joel" wrote:

I wanted to put the award information for each row back into the Award
worksheet.

Here are the changes

Sub MakeBuckets()

Const AmountCol As String = "C"
Const TempShtName As String = "Temporary"

Dim percent As Single
Dim RangeTotal As Single

Set AwardSht = Sheets("Awards")
Set ContractSht = Sheets("Contracts")

Application.DisplayAlerts = False

'Delete all worksheets except Awards and Contracts
For ShtCount = Sheets.Count To 1 Step -1
If Sheets(ShtCount).Name "Awards" And _
Sheets(ShtCount).Name "Contracts" Then

Sheets(ShtCount).Delete
End If
Next ShtCount

'create temporary sheet for making buckets
Set Tmpsht = Sheets.Add(after:=Sheets(Sheets.Count))
Tmpsht.Name = TempShtName

With AwardSht
'add header row info
.Range("A1") = "%"
.Range("B1") = "Min"
.Range("C1") = "Max"
.Range("D1") = "Range Total"
.Range("E1") = "Expected Award"
.Range("F1") = "Actual Award"
.Range("G1") = "Actual %"

'get each bucket
RowCount = 2
Do While .Range("A" & RowCount) ""

With Tmpsht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With

percent = .Range("A" & RowCount)
MinAward = .Range("B" & RowCount)
MaxAward = .Range("C" & RowCount)

'only copy award range once if there are multiple
'awards in the same range
If MinAward .Range("B" & (RowCount - 1)) Or _
MaxAward .Range("C" & (RowCount - 1)) Then

With ContractSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
With .Columns(AmountCol & ":" & AmountCol)
.AutoFilter
End With


.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="" & MaxAward

'clear temporary sheet
Tmpsht.Cells.ClearContents

'copy filtered data to temporary sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=Tmpsht.Cells


'sort contracts highest to lowest
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
.Rows("1:" & LastRow).Sort _
key1:=.Range(AmountCol & "1"), _
order1:=xlDescending


'Get Grand Total for range
RangeTotal = Evaluate( _
"Sum(" & TempShtName & "!" & AmountCol & "2:" & _
AmountCol & LastRow & ")")

End With

End If

Award = RangeTotal * percent
Call GetContracts(TempShtName, AmountCol, Award)

'create Range sheet sheet for making buckets
shtname = "(" & (RowCount - 1) & ") " & MinAward & " - " & MaxAward

Set RangeSht = Sheets.Add(after:=Sheets(Sheets.Count))
RangeSht.Name = shtname

With Tmpsht

'copy filtered data to Award sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=RangeSht.Cells

End With


With RangeSht
'remove column IV from the Award sheet
.Columns("IV").Delete

'Get Last row
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
SummaryRow = LastRow + 2
'put formula total columns
.Range(AmountCol & SummaryRow).Offset(0, -1) = "Total Awards"
.Range(AmountCol & SummaryRow).Offset(0, 0).Formula = _
"=SUM(" & AmountCol & "2:" & AmountCol & LastRow & ")"
Total = .Range(AmountCol & SummaryRow).Offset(0, 0)
.Range(AmountCol & SummaryRow).Offset(1, -1) = "Total Range"
.Range(AmountCol & SummaryRow).Offset(1, 0) = RangeTotal
.Range(AmountCol & SummaryRow).Offset(2, -1) = "Expected Award"
.Range(AmountCol & SummaryRow).Offset(2, 0) = RangeTotal * percent
.Range(AmountCol & SummaryRow).Offset(3, -1) = "Expected Percent"
.Range(AmountCol & SummaryRow).Offset(3, 0) = percent
.Range(AmountCol & SummaryRow).Offset(4, -1) = "Actual Percent"
.Range(AmountCol & SummaryRow).Offset(4, 0) = Total / RangeTotal

.Columns.AutoFit
End With

With AwardSht
.Range("D" & RowCount) = RangeTotal
.Range("E" & RowCount) = RangeTotal * percent
.Range("F" & RowCount) = Total
.Range("G" & RowCount) = Total / RangeTotal
End With

RowCount = RowCount + 1
Loop
End With

With ContractSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With

With AwardSht
.Columns.AutoFit
End With

Application.DisplayAlerts = False

End Sub
Sub GetContracts(ByVal shtname As String, ByVal AmountCol As String, _
ByVal Award As Single)

'sub routine to get a percentage of the contracts in a range
'filter the worksheet
'main routine will copy the filtered data

With Sheets(shtname)
'replace any awarded contract with an X in column IV with A (awarded)
'this is so the same contract doesn't get awarded twice
.Columns("IV").Replace _
What:="X", _
Replacement:="A", _
LookAt:=xlWhole


LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row


Total = 0
'put an X in column IV for every contract that keeps total under Awards
For RowCount = 2 To LastRow
'test if contract already awareded
If .Range("IV" & RowCount) "A" Then
Amount = .Range(AmountCol & RowCount)
If Amount + Total = Award Then
.Range("IV" & RowCount) = "X"
Total = Total + Amount
End If
End If
Next RowCount

'check if ther is filtered data
Cellsnotempty = Evaluate("Counta(" & shtname & "!IV:IV)")

If Cellsnotempty 0 Then

'filter on formula in column IV
With .Columns("IV:IV")
.AutoFilter
End With


.Range("IV2:IV" & LastRow).AutoFilter _
Field:=1, _
Criteria1:="X"
End If

End With


End Sub

Again, I knew this question was coming. I like to do programs in pieces
getting one part done and then addin features later. No problem


I added a new function to filter the temporay sheet to look for empty cells
in column IV which is the unawarded contracts. I had to call the sub twice.
The code before clearing the temporary sheet for each range copies the
unawarded contracts. I also have to call it at the end of the program to get
the unawarded from the last range.



Sub MakeBuckets()

Const AmountCol As String = "C"
Const TempShtName As String = "Temporary"
Const NonAwardShtName As String = "Non-Awarded"

Dim percent As Single
Dim RangeTotal As Single

Set AwardSht = Sheets("Awards")
Set ContractSht = Sheets("Contracts")

Application.DisplayAlerts = False

'Delete all worksheets except Awards and Contracts
For ShtCount = Sheets.Count To 1 Step -1
If Sheets(ShtCount).Name "Awards" And _
Sheets(ShtCount).Name "Contracts" Then

Sheets(ShtCount).Delete
End If
Next ShtCount

'create temporary sheet for making buckets
Set TmpSht = Sheets.Add(after:=Sheets(Sheets.Count))
TmpSht.Name = TempShtName

'create temporary sheet for making buckets
Set NonAwardSht = Sheets.Add(after:=Sheets(Sheets.Count))
NonAwardSht.Name = NonAwardShtName
'put header row in non award sheet
ContractSht.Rows(1).Copy _
Destination:=NonAwardSht.Rows(1)

With AwardSht
'add header row info
.Range("A1") = "%"
.Range("B1") = "Min"
.Range("C1") = "Max"
.Range("D1") = "Range Total"
.Range("E1") = "Expected Award"
.Range("F1") = "Actual Award"
.Range("G1") = "Actual %"

'get each bucket
RowCount = 2
Do While .Range("A" & RowCount) ""

With TmpSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With

percent = .Range("A" & RowCount)
MinAward = .Range("B" & RowCount)
MaxAward = .Range("C" & RowCount)

'only copy award range once if there are multiple
'awards in the same range
If MinAward .Range("B" & (RowCount - 1)) Or _
MaxAward .Range("C" & (RowCount - 1)) Then

With TmpSht
'copy non awarded contracts from last range
'don't need to copy for the first range where rowcount = 2
If RowCount 2 Then
Call CopyNonAwarded(TempShtName, NonAwardShtName, AmountCol)
End If
'clear temporary sheet
TmpSht.Cells.ClearContents

End With

With ContractSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
With .Columns(AmountCol & ":" & AmountCol)
.AutoFilter
End With


.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="" & MaxAward


'copy filtered data to temporary sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=TmpSht.Cells


'sort contracts highest to lowest
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
.Rows("1:" & LastRow).Sort _
key1:=.Range(AmountCol & "1"), _
order1:=xlDescending


'Get Grand Total for range
RangeTotal = Evaluate( _
"Sum(" & TempShtName & "!" & AmountCol & "2:" & _
AmountCol & LastRow & ")")

End With

End If

Award = RangeTotal * percent
Call GetContracts(TempShtName, AmountCol, Award)

'create Range sheet sheet for making buckets
shtname = "(" & (RowCount - 1) & ") " & MinAward & " - " & MaxAward

Set RangeSht = Sheets.Add(after:=Sheets(Sheets.Count))
RangeSht.Name = shtname

With TmpSht

'copy filtered data to Award sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=RangeSht.Cells

End With


With RangeSht
'remove column IV from the Award sheet
.Columns("IV").Delete

'Get Last row
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
SummaryRow = LastRow + 2
'put formula total columns
.Range(AmountCol & SummaryRow).Offset(0, -1) = "Total Awards"
.Range(AmountCol & SummaryRow).Offset(0, 0).Formula = _
"=SUM(" & AmountCol & "2:" & AmountCol & LastRow & ")"
Total = .Range(AmountCol & SummaryRow).Offset(0, 0)
.Range(AmountCol & SummaryRow).Offset(1, -1) = "Total Range"
.Range(AmountCol & SummaryRow).Offset(1, 0) = RangeTotal
.Range(AmountCol & SummaryRow).Offset(2, -1) = "Expected Award"
.Range(AmountCol & SummaryRow).Offset(2, 0) = RangeTotal * percent
.Range(AmountCol & SummaryRow).Offset(3, -1) = "Expected Percent"
.Range(AmountCol & SummaryRow).Offset(3, 0) = percent
.Range(AmountCol & SummaryRow).Offset(4, -1) = "Actual Percent"
.Range(AmountCol & SummaryRow).Offset(4, 0) = Total / RangeTotal

.Columns.AutoFit
End With

With AwardSht
.Range("D" & RowCount) = RangeTotal
.Range("E" & RowCount) = RangeTotal * percent
.Range("F" & RowCount) = Total
.Range("G" & RowCount) = Total / RangeTotal
End With

RowCount = RowCount + 1
Loop
End With

With ContractSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With

With AwardSht
.Columns.AutoFit
End With

'copy last set of un awarded contracts
With TmpSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
Call CopyNonAwarded(TempShtName, NonAwardShtName, AmountCol)

'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

End With


Application.DisplayAlerts = False

End Sub
Sub GetContracts(ByVal shtname As String, ByVal AmountCol As String, _
ByVal Award As Single)

'sub routine to get a percentage of the contracts in a range
'filter the worksheet
'main routine will copy the filtered data

With Sheets(shtname)
'replace any awarded contract with an X in column IV with A (awarded)
'this is so the same contract doesn't get awarded twice
.Columns("IV").Replace _
What:="X", _
Replacement:="A", _
LookAt:=xlWhole


LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row


Total = 0
'put an X in column IV for every contract that keeps total under Awards
For RowCount = 2 To LastRow
'test if contract already awareded
If .Range("IV" & RowCount) "A" Then
Amount = .Range(AmountCol & RowCount)
If Amount + Total = Award Then
.Range("IV" & RowCount) = "X"
Total = Total + Amount
End If
End If
Next RowCount

'check if there is filtered data
Cellsnotempty = Evaluate("Counta(" & shtname & "!IV:IV)")

If Cellsnotempty 0 Then

'filter on formula in column IV
With .Columns("IV:IV")
.AutoFilter
End With


.Range("IV2:IV" & LastRow).AutoFilter _
Field:=1, _
Criteria1:="X"
End If

End With


End Sub
Sub CopyNonAwarded(ByVal tmpshtname As String, NonAwardShtName, ByVal
AmountCol As String)

Set NonAwardSht = Sheets(NonAwardShtName)

With Sheets(tmpshtname)
'filter items that don't contain blank in column IV

'check if there is filtered data
Cellsnotempty = Evaluate("Counta(" & tmpshtname & "!IV:IV)")

If Cellsnotempty 0 Then
LastRow = NonAwardSht.Range(AmountCol & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row

'filter on formula in column IV
With .Columns("IV:IV")
.AutoFilter
End With

.Range("IV2:IV" & LastRow).AutoFilter _
Field:=1, _
Criteria1:=""

.Rows("2:" & LastRow).SpecialCells(Type:=xlCellTypeVisible).Cop y _
Destination:=NonAwardSht.Rows(NewRow)
End If
End With
End Sub

Hi Joel,

I got an error message and this line is highlighted and the error message is
"Sub or function no defined"

Call CopyNonAwarded(TempShtName, NonAwardShtName, AmountCol)


"Joel" wrote:

Again, I knew this question was coming. I like to do programs in pieces
getting one part done and then addin features later. No problem


I added a new function to filter the temporay sheet to look for empty cells
in column IV which is the unawarded contracts. I had to call the sub twice.
The code before clearing the temporary sheet for each range copies the
unawarded contracts. I also have to call it at the end of the program to get
the unawarded from the last range.



Sub MakeBuckets()

Const AmountCol As String = "C"
Const TempShtName As String = "Temporary"
Const NonAwardShtName As String = "Non-Awarded"

Dim percent As Single
Dim RangeTotal As Single

Set AwardSht = Sheets("Awards")
Set ContractSht = Sheets("Contracts")

Application.DisplayAlerts = False

'Delete all worksheets except Awards and Contracts
For ShtCount = Sheets.Count To 1 Step -1
If Sheets(ShtCount).Name "Awards" And _
Sheets(ShtCount).Name "Contracts" Then

Sheets(ShtCount).Delete
End If
Next ShtCount

'create temporary sheet for making buckets
Set TmpSht = Sheets.Add(after:=Sheets(Sheets.Count))
TmpSht.Name = TempShtName

'create temporary sheet for making buckets
Set NonAwardSht = Sheets.Add(after:=Sheets(Sheets.Count))
NonAwardSht.Name = NonAwardShtName
'put header row in non award sheet
ContractSht.Rows(1).Copy _
Destination:=NonAwardSht.Rows(1)

With AwardSht
'add header row info
.Range("A1") = "%"
.Range("B1") = "Min"
.Range("C1") = "Max"
.Range("D1") = "Range Total"
.Range("E1") = "Expected Award"
.Range("F1") = "Actual Award"
.Range("G1") = "Actual %"

'get each bucket
RowCount = 2
Do While .Range("A" & RowCount) ""

With TmpSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With

percent = .Range("A" & RowCount)
MinAward = .Range("B" & RowCount)
MaxAward = .Range("C" & RowCount)

'only copy award range once if there are multiple
'awards in the same range
If MinAward .Range("B" & (RowCount - 1)) Or _
MaxAward .Range("C" & (RowCount - 1)) Then

With TmpSht
'copy non awarded contracts from last range
'don't need to copy for the first range where rowcount = 2
If RowCount 2 Then
Call CopyNonAwarded(TempShtName, NonAwardShtName, AmountCol)
End If
'clear temporary sheet
TmpSht.Cells.ClearContents

End With

With ContractSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
With .Columns(AmountCol & ":" & AmountCol)
.AutoFilter
End With


.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="" & MaxAward


'copy filtered data to temporary sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=TmpSht.Cells


'sort contracts highest to lowest
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
.Rows("1:" & LastRow).Sort _
key1:=.Range(AmountCol & "1"), _
order1:=xlDescending


'Get Grand Total for range
RangeTotal = Evaluate( _
"Sum(" & TempShtName & "!" & AmountCol & "2:" & _
AmountCol & LastRow & ")")

End With

End If

Award = RangeTotal * percent
Call GetContracts(TempShtName, AmountCol, Award)

'create Range sheet sheet for making buckets
shtname = "(" & (RowCount - 1) & ") " & MinAward & " - " & MaxAward

Set RangeSht = Sheets.Add(after:=Sheets(Sheets.Count))
RangeSht.Name = shtname

With TmpSht

'copy filtered data to Award sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=RangeSht.Cells

End With


With RangeSht
'remove column IV from the Award sheet
.Columns("IV").Delete

'Get Last row
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
SummaryRow = LastRow + 2
'put formula total columns
.Range(AmountCol & SummaryRow).Offset(0, -1) = "Total Awards"
.Range(AmountCol & SummaryRow).Offset(0, 0).Formula = _
"=SUM(" & AmountCol & "2:" & AmountCol & LastRow & ")"
Total = .Range(AmountCol & SummaryRow).Offset(0, 0)
.Range(AmountCol & SummaryRow).Offset(1, -1) = "Total Range"
.Range(AmountCol & SummaryRow).Offset(1, 0) = RangeTotal
.Range(AmountCol & SummaryRow).Offset(2, -1) = "Expected Award"
.Range(AmountCol & SummaryRow).Offset(2, 0) = RangeTotal * percent
.Range(AmountCol & SummaryRow).Offset(3, -1) = "Expected Percent"
.Range(AmountCol & SummaryRow).Offset(3, 0) = percent
.Range(AmountCol & SummaryRow).Offset(4, -1) = "Actual Percent"
.Range(AmountCol & SummaryRow).Offset(4, 0) = Total / RangeTotal

.Columns.AutoFit
End With

With AwardSht
.Range("D" & RowCount) = RangeTotal
.Range("E" & RowCount) = RangeTotal * percent
.Range("F" & RowCount) = Total
.Range("G" & RowCount) = Total / RangeTotal
End With

RowCount = RowCount + 1
Loop
End With

With ContractSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With

With AwardSht
.Columns.AutoFit
End With

'copy last set of un awarded contracts
With TmpSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
Call CopyNonAwarded(TempShtName, NonAwardShtName, AmountCol)

'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

End With


Application.DisplayAlerts = False

End Sub
Sub GetContracts(ByVal shtname As String, ByVal AmountCol As String, _
ByVal Award As Single)

'sub routine to get a percentage of the contracts in a range
'filter the worksheet
'main routine will copy the filtered data

With Sheets(shtname)
'replace any awarded contract with an X in column IV with A (awarded)
'this is so the same contract doesn't get awarded twice
.Columns("IV").Replace _
What:="X", _
Replacement:="A", _
LookAt:=xlWhole


LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row


Total = 0
'put an X in column IV for every contract that keeps total under Awards
For RowCount = 2 To LastRow
'test if contract already awareded
If .Range("IV" & RowCount) "A" Then
Amount = .Range(AmountCol & RowCount)
If Amount + Total = Award Then
.Range("IV" & RowCount) = "X"
Total = Total + Amount
End If
End If
Next RowCount

'check if there is filtered data
Cellsnotempty = Evaluate("Counta(" & shtname & "!IV:IV)")

If Cellsnotempty 0 Then

'filter on formula in column IV
With .Columns("IV:IV")
.AutoFilter
End With


.Range("IV2:IV" & LastRow).AutoFilter _
Field:=1, _
Criteria1:="X"
End If

End With


End Sub
Sub CopyNonAwarded(ByVal tmpshtname As String, NonAwardShtName, ByVal
AmountCol As String)

Set NonAwardSht = Sheets(NonAwardShtName)

With Sheets(tmpshtname)
'filter items that don't contain blank in column IV

'check if there is filtered data
Cellsnotempty = Evaluate("Counta(" & tmpshtname & "!IV:IV)")

If Cellsnotempty 0 Then
LastRow = NonAwardSht.Range(AmountCol & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row

'filter on formula in column IV
With .Columns("IV:IV")
.AutoFilter
End With

.Range("IV2:IV" & LastRow).AutoFilter _
Field:=1, _
Criteria1:=""

.Rows("2:" & LastRow).SpecialCells(Type:=xlCellTypeVisible).Cop y _
Destination:=NonAwardSht.Rows(NewRow)
End If
End With
End Sub

I got it, there a line in the sub that you had created for copynonawarded,
now it works great, thank you Joel, you are great

"Joel" wrote:

Again, I knew this question was coming. I like to do programs in pieces
getting one part done and then addin features later. No problem


I added a new function to filter the temporay sheet to look for empty cells
in column IV which is the unawarded contracts. I had to call the sub twice.
The code before clearing the temporary sheet for each range copies the
unawarded contracts. I also have to call it at the end of the program to get
the unawarded from the last range.



Sub MakeBuckets()

Const AmountCol As String = "C"
Const TempShtName As String = "Temporary"
Const NonAwardShtName As String = "Non-Awarded"

Dim percent As Single
Dim RangeTotal As Single

Set AwardSht = Sheets("Awards")
Set ContractSht = Sheets("Contracts")

Application.DisplayAlerts = False

'Delete all worksheets except Awards and Contracts
For ShtCount = Sheets.Count To 1 Step -1
If Sheets(ShtCount).Name "Awards" And _
Sheets(ShtCount).Name "Contracts" Then

Sheets(ShtCount).Delete
End If
Next ShtCount

'create temporary sheet for making buckets
Set TmpSht = Sheets.Add(after:=Sheets(Sheets.Count))
TmpSht.Name = TempShtName

'create temporary sheet for making buckets
Set NonAwardSht = Sheets.Add(after:=Sheets(Sheets.Count))
NonAwardSht.Name = NonAwardShtName
'put header row in non award sheet
ContractSht.Rows(1).Copy _
Destination:=NonAwardSht.Rows(1)

With AwardSht
'add header row info
.Range("A1") = "%"
.Range("B1") = "Min"
.Range("C1") = "Max"
.Range("D1") = "Range Total"
.Range("E1") = "Expected Award"
.Range("F1") = "Actual Award"
.Range("G1") = "Actual %"

'get each bucket
RowCount = 2
Do While .Range("A" & RowCount) ""

With TmpSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With

percent = .Range("A" & RowCount)
MinAward = .Range("B" & RowCount)
MaxAward = .Range("C" & RowCount)

'only copy award range once if there are multiple
'awards in the same range
If MinAward .Range("B" & (RowCount - 1)) Or _
MaxAward .Range("C" & (RowCount - 1)) Then

With TmpSht
'copy non awarded contracts from last range
'don't need to copy for the first range where rowcount = 2
If RowCount 2 Then
Call CopyNonAwarded(TempShtName, NonAwardShtName, AmountCol)
End If
'clear temporary sheet
TmpSht.Cells.ClearContents

End With

With ContractSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
With .Columns(AmountCol & ":" & AmountCol)
.AutoFilter
End With


.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="" & MaxAward


'copy filtered data to temporary sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=TmpSht.Cells


'sort contracts highest to lowest
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
.Rows("1:" & LastRow).Sort _
key1:=.Range(AmountCol & "1"), _
order1:=xlDescending


'Get Grand Total for range
RangeTotal = Evaluate( _
"Sum(" & TempShtName & "!" & AmountCol & "2:" & _
AmountCol & LastRow & ")")

End With

End If

Award = RangeTotal * percent
Call GetContracts(TempShtName, AmountCol, Award)

'create Range sheet sheet for making buckets
shtname = "(" & (RowCount - 1) & ") " & MinAward & " - " & MaxAward

Set RangeSht = Sheets.Add(after:=Sheets(Sheets.Count))
RangeSht.Name = shtname

With TmpSht

'copy filtered data to Award sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=RangeSht.Cells

End With


With RangeSht
'remove column IV from the Award sheet
.Columns("IV").Delete

'Get Last row
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
SummaryRow = LastRow + 2
'put formula total columns
.Range(AmountCol & SummaryRow).Offset(0, -1) = "Total Awards"
.Range(AmountCol & SummaryRow).Offset(0, 0).Formula = _
"=SUM(" & AmountCol & "2:" & AmountCol & LastRow & ")"
Total = .Range(AmountCol & SummaryRow).Offset(0, 0)
.Range(AmountCol & SummaryRow).Offset(1, -1) = "Total Range"
.Range(AmountCol & SummaryRow).Offset(1, 0) = RangeTotal
.Range(AmountCol & SummaryRow).Offset(2, -1) = "Expected Award"
.Range(AmountCol & SummaryRow).Offset(2, 0) = RangeTotal * percent
.Range(AmountCol & SummaryRow).Offset(3, -1) = "Expected Percent"
.Range(AmountCol & SummaryRow).Offset(3, 0) = percent
.Range(AmountCol & SummaryRow).Offset(4, -1) = "Actual Percent"
.Range(AmountCol & SummaryRow).Offset(4, 0) = Total / RangeTotal

.Columns.AutoFit
End With

With AwardSht
.Range("D" & RowCount) = RangeTotal
.Range("E" & RowCount) = RangeTotal * percent
.Range("F" & RowCount) = Total
.Range("G" & RowCount) = Total / RangeTotal
End With

RowCount = RowCount + 1
Loop
End With

With ContractSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With

With AwardSht
.Columns.AutoFit
End With

'copy last set of un awarded contracts
With TmpSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
Call CopyNonAwarded(TempShtName, NonAwardShtName, AmountCol)

'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

End With


Application.DisplayAlerts = False

End Sub
Sub GetContracts(ByVal shtname As String, ByVal AmountCol As String, _
ByVal Award As Single)

'sub routine to get a percentage of the contracts in a range
'filter the worksheet
'main routine will copy the filtered data

With Sheets(shtname)
'replace any awarded contract with an X in column IV with A (awarded)
'this is so the same contract doesn't get awarded twice
.Columns("IV").Replace _
What:="X", _
Replacement:="A", _
LookAt:=xlWhole


LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row


Total = 0
'put an X in column IV for every contract that keeps total under Awards
For RowCount = 2 To LastRow
'test if contract already awareded
If .Range("IV" & RowCount) "A" Then
Amount = .Range(AmountCol & RowCount)
If Amount + Total = Award Then
.Range("IV" & RowCount) = "X"
Total = Total + Amount
End If
End If
Next RowCount

'check if there is filtered data
Cellsnotempty = Evaluate("Counta(" & shtname & "!IV:IV)")

If Cellsnotempty 0 Then

'filter on formula in column IV
With .Columns("IV:IV")
.AutoFilter
End With


.Range("IV2:IV" & LastRow).AutoFilter _
Field:=1, _
Criteria1:="X"
End If

End With


End Sub
Sub CopyNonAwarded(ByVal tmpshtname As String, NonAwardShtName, ByVal
AmountCol As String)

Set NonAwardSht = Sheets(NonAwardShtName)

With Sheets(tmpshtname)
'filter items that don't contain blank in column IV

'check if there is filtered data
Cellsnotempty = Evaluate("Counta(" & tmpshtname & "!IV:IV)")

If Cellsnotempty 0 Then
LastRow = NonAwardSht.Range(AmountCol & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row

'filter on formula in column IV
With .Columns("IV:IV")
.AutoFilter
End With

.Range("IV2:IV" & LastRow).AutoFilter _
Field:=1, _
Criteria1:=""

.Rows("2:" & LastRow).SpecialCells(Type:=xlCellTypeVisible).Cop y _
Destination:=NonAwardSht.Rows(NewRow)
End If
End With
End Sub

hi Joel,

if there are no non-awarded contract it will highlight these line and give
me error

.Rows("2:" & LastRow).SpecialCells(Type:=xlCellTypeVisible).Cop y _
Destination:=NonAwardSht.Rows(NewRow)


"Joel" wrote:

Again, I knew this question was coming. I like to do programs in pieces
getting one part done and then addin features later. No problem


I added a new function to filter the temporay sheet to look for empty cells
in column IV which is the unawarded contracts. I had to call the sub twice.
The code before clearing the temporary sheet for each range copies the
unawarded contracts. I also have to call it at the end of the program to get
the unawarded from the last range.



Sub MakeBuckets()

Const AmountCol As String = "C"
Const TempShtName As String = "Temporary"
Const NonAwardShtName As String = "Non-Awarded"

Dim percent As Single
Dim RangeTotal As Single

Set AwardSht = Sheets("Awards")
Set ContractSht = Sheets("Contracts")

Application.DisplayAlerts = False

'Delete all worksheets except Awards and Contracts
For ShtCount = Sheets.Count To 1 Step -1
If Sheets(ShtCount).Name "Awards" And _
Sheets(ShtCount).Name "Contracts" Then

Sheets(ShtCount).Delete
End If
Next ShtCount

'create temporary sheet for making buckets
Set TmpSht = Sheets.Add(after:=Sheets(Sheets.Count))
TmpSht.Name = TempShtName

'create temporary sheet for making buckets
Set NonAwardSht = Sheets.Add(after:=Sheets(Sheets.Count))
NonAwardSht.Name = NonAwardShtName
'put header row in non award sheet
ContractSht.Rows(1).Copy _
Destination:=NonAwardSht.Rows(1)

With AwardSht
'add header row info
.Range("A1") = "%"
.Range("B1") = "Min"
.Range("C1") = "Max"
.Range("D1") = "Range Total"
.Range("E1") = "Expected Award"
.Range("F1") = "Actual Award"
.Range("G1") = "Actual %"

'get each bucket
RowCount = 2
Do While .Range("A" & RowCount) ""

With TmpSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With

percent = .Range("A" & RowCount)
MinAward = .Range("B" & RowCount)
MaxAward = .Range("C" & RowCount)

'only copy award range once if there are multiple
'awards in the same range
If MinAward .Range("B" & (RowCount - 1)) Or _
MaxAward .Range("C" & (RowCount - 1)) Then

With TmpSht
'copy non awarded contracts from last range
'don't need to copy for the first range where rowcount = 2
If RowCount 2 Then
Call CopyNonAwarded(TempShtName, NonAwardShtName, AmountCol)
End If
'clear temporary sheet
TmpSht.Cells.ClearContents

End With

With ContractSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
With .Columns(AmountCol & ":" & AmountCol)
.AutoFilter
End With


.Range(AmountCol & "2:" & AmountCol & LastRow).AutoFilter _
Field:=1, _
Criteria1:="=" & MinAward, _
Operator:=xlAnd, _
Criteria2:="" & MaxAward


'copy filtered data to temporary sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=TmpSht.Cells


'sort contracts highest to lowest
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
.Rows("1:" & LastRow).Sort _
key1:=.Range(AmountCol & "1"), _
order1:=xlDescending


'Get Grand Total for range
RangeTotal = Evaluate( _
"Sum(" & TempShtName & "!" & AmountCol & "2:" & _
AmountCol & LastRow & ")")

End With

End If

Award = RangeTotal * percent
Call GetContracts(TempShtName, AmountCol, Award)

'create Range sheet sheet for making buckets
shtname = "(" & (RowCount - 1) & ") " & MinAward & " - " & MaxAward

Set RangeSht = Sheets.Add(after:=Sheets(Sheets.Count))
RangeSht.Name = shtname

With TmpSht

'copy filtered data to Award sheet
.Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _
Destination:=RangeSht.Cells

End With


With RangeSht
'remove column IV from the Award sheet
.Columns("IV").Delete

'Get Last row
LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row
SummaryRow = LastRow + 2
'put formula total columns
.Range(AmountCol & SummaryRow).Offset(0, -1) = "Total Awards"
.Range(AmountCol & SummaryRow).Offset(0, 0).Formula = _
"=SUM(" & AmountCol & "2:" & AmountCol & LastRow & ")"
Total = .Range(AmountCol & SummaryRow).Offset(0, 0)
.Range(AmountCol & SummaryRow).Offset(1, -1) = "Total Range"
.Range(AmountCol & SummaryRow).Offset(1, 0) = RangeTotal
.Range(AmountCol & SummaryRow).Offset(2, -1) = "Expected Award"
.Range(AmountCol & SummaryRow).Offset(2, 0) = RangeTotal * percent
.Range(AmountCol & SummaryRow).Offset(3, -1) = "Expected Percent"
.Range(AmountCol & SummaryRow).Offset(3, 0) = percent
.Range(AmountCol & SummaryRow).Offset(4, -1) = "Actual Percent"
.Range(AmountCol & SummaryRow).Offset(4, 0) = Total / RangeTotal

.Columns.AutoFit
End With

With AwardSht
.Range("D" & RowCount) = RangeTotal
.Range("E" & RowCount) = RangeTotal * percent
.Range("F" & RowCount) = Total
.Range("G" & RowCount) = Total / RangeTotal
End With

RowCount = RowCount + 1
Loop
End With

With ContractSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
End With

With AwardSht
.Columns.AutoFit
End With

'copy last set of un awarded contracts
With TmpSht
'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If
Call CopyNonAwarded(TempShtName, NonAwardShtName, AmountCol)

'turn off autofilter
If .AutoFilterMode Then
.Cells.AutoFilter
End If

End With


Application.DisplayAlerts = False

End Sub
Sub GetContracts(ByVal shtname As String, ByVal AmountCol As String, _
ByVal Award As Single)

'sub routine to get a percentage of the contracts in a range
'filter the worksheet
'main routine will copy the filtered data

With Sheets(shtname)
'replace any awarded contract with an X in column IV with A (awarded)
'this is so the same contract doesn't get awarded twice
.Columns("IV").Replace _
What:="X", _
Replacement:="A", _
LookAt:=xlWhole


LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row


Total = 0
'put an X in column IV for every contract that keeps total under Awards
For RowCount = 2 To LastRow
'test if contract already awareded
If .Range("IV" & RowCount) "A" Then
Amount = .Range(AmountCol & RowCount)
If Amount + Total = Award Then
.Range("IV" & RowCount) = "X"
Total = Total + Amount
End If
End If
Next RowCount

'check if there is filtered data
Cellsnotempty = Evaluate("Counta(" & shtname & "!IV:IV)")

If Cellsnotempty 0 Then

'filter on formula in column IV
With .Columns("IV:IV")
.AutoFilter
End With


.Range("IV2:IV" & LastRow).AutoFilter _
Field:=1, _
Criteria1:="X"
End If

End With


End Sub
Sub CopyNonAwarded(ByVal tmpshtname As String, NonAwardShtName, ByVal
AmountCol As String)

Set NonAwardSht = Sheets(NonAwardShtName)

With Sheets(tmpshtname)
'filter items that don't contain blank in column IV

'check if there is filtered data
Cellsnotempty = Evaluate("Counta(" & tmpshtname & "!IV:IV)")

If Cellsnotempty 0 Then
LastRow = NonAwardSht.Range(AmountCol & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1

LastRow = .Range(AmountCol & Rows.Count).End(xlUp).Row

'filter on formula in column IV
With .Columns("IV:IV")
.AutoFilter
End With

.Range("IV2:IV" & LastRow).AutoFilter _
Field:=1, _
Criteria1:=""

.Rows("2:" & LastRow).SpecialCells(Type:=xlCellTypeVisible).Cop y _
Destination:=NonAwardSht.Rows(NewRow)
End If
End With
End Sub