If this is your first visit, be sure to check out the FAQ by clicking the link above. You may have to register before you can post: click the register link above to proceed. To start viewing messages, select the forum that you want to visit from the selection below. |
|
|
Thread Tools | Display Modes |
#21
|
|||
|
|||
copy multiple records based on criteria or total amount
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) '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 _ |
#22
|
|||
|
|||
copy multiple records based on criteria or total amount
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) |
#23
|
|||
|
|||
copy multiple records based on criteria or total amount
from
For ShtCount = Sheets.Count To 1 Step -1 If Sheets(ShtCount).Name "Awards" And _ Sheets(ShtCount).Name "Contracts" Then to For ShtCount = Sheets.Count To 1 Step -1 If Sheets(ShtCount).Name "Awards" And _ Sheets(ShtCount).Name "Contracts" And _ Sheets(ShtCount).Name "Forced" Then "David" wrote: 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 |
Thread Tools | |
Display Modes | |
|
|