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).Copy _
Destination:=NonAwardSht.Rows(NewRow)
End If
End With
End Sub
