Hi Joel,

I want to add another sheet to the file called "Forced" and i dont want the
macro to delete it, what could should i change?

"Joel" wrote:

Try this change. I didn't test but should work

Set CopyRange = .Rows("2:" & LastRow) _
.SpecialCells(Type:=xlCellTypeVisible)
If Not CopyRange Is Nothing Then
CopyRange.Copy _
Destination:=NonAwardSht.Rows(NewRow)
End If

You don't have to manually assign the unasigned contacts. If you have a
rane with buckets

10%, 30%, 20%,40%

You can make the last bucket 100% and it will get all the unassigned
contracts. Also changing the order of the buckets gets different results.
I'm no sure if it is better to assign the buckets from lowest to highest
percenage or highest to lowest percentage.

"David" wrote:

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)