Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
Hi everyone,
I have a worksheet with over 20000 records, i did a dcount based on amounts from 500-5000 and i got a result of 250 records, and dsum based on the same criteria (500-5000) i got 2,000,000. further i want to distribute the number of contracts and amount into 4 buckets as follow Dsum result 10% 10% 30% 50% total 1,000,000 100,000 100,000 300,000 500,000 1,000,000 Dcount result 10% 10% 30% 50% total 250 25 25 75 125 250 Can i somehow exctract, copy list of contracts in each bucket that will add up to the dsum amount distribution for each bucket? for example: a formula or macro that will give me 25 contracts out of 20,000 when i add the amounts it should come up to 100,000 and all contracts must be between 500-5000. I really appreciate any help i can get on this one. |
#2
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
Your results won't be exact but close to the results you want.
1) Sort the records by amount 2) In a new column on the 1st record that is greater or equal to $500.00 put this formula =sum(C$100:C100) Notice the dollar sign is on the first 100 only where the row number is the 1st row = 500. 3) copy formula down the worksheet. 4) Your buckets can be extract base on the new column amount bucket 1 : the totals 0 to $100,000 bucket 2 : the totals 100,000 to $200,000 bucket 3 : the totals 200,000 to $500,000 bucket 4 : the totals 500,000 to $1,000,000 bucket 5 : the totals 1,000,000 to $2,000,000 "David" wrote: Hi everyone, I have a worksheet with over 20000 records, i did a dcount based on amounts from 500-5000 and i got a result of 250 records, and dsum based on the same criteria (500-5000) i got 2,000,000. further i want to distribute the number of contracts and amount into 4 buckets as follow Dsum result 10% 10% 30% 50% total 1,000,000 100,000 100,000 300,000 500,000 1,000,000 Dcount result 10% 10% 30% 50% total 250 25 25 75 125 250 Can i somehow exctract, copy list of contracts in each bucket that will add up to the dsum amount distribution for each bucket? for example: a formula or macro that will give me 25 contracts out of 20,000 when i add the amounts it should come up to 100,000 and all contracts must be between 500-5000. I really appreciate any help i can get on this one. |
#3
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
Hi Joel,
I really appreciate your help, however this will give me a running total on the new column where for example the first 100 records will add up to 100K, and then i would have to start the same running total to get the next bucket. Is there away that i can divide the whole 250 records into 4 buckets by pressing a button or running a macro which would base the division on the result of dcount and dsum. since i will be doing this in the future with much larger file and more than 100 buckets "Joel" wrote: Your results won't be exact but close to the results you want. 1) Sort the records by amount 2) In a new column on the 1st record that is greater or equal to $500.00 put this formula =sum(C$100:C100) Notice the dollar sign is on the first 100 only where the row number is the 1st row = 500. 3) copy formula down the worksheet. 4) Your buckets can be extract base on the new column amount bucket 1 : the totals 0 to $100,000 bucket 2 : the totals 100,000 to $200,000 bucket 3 : the totals 200,000 to $500,000 bucket 4 : the totals 500,000 to $1,000,000 bucket 5 : the totals 1,000,000 to $2,000,000 "David" wrote: Hi everyone, I have a worksheet with over 20000 records, i did a dcount based on amounts from 500-5000 and i got a result of 250 records, and dsum based on the same criteria (500-5000) i got 2,000,000. further i want to distribute the number of contracts and amount into 4 buckets as follow Dsum result 10% 10% 30% 50% total 1,000,000 100,000 100,000 300,000 500,000 1,000,000 Dcount result 10% 10% 30% 50% total 250 25 25 75 125 250 Can i somehow exctract, copy list of contracts in each bucket that will add up to the dsum amount distribution for each bucket? for example: a formula or macro that will give me 25 contracts out of 20,000 when i add the amounts it should come up to 100,000 and all contracts must be between 500-5000. I really appreciate any help i can get on this one. |
#4
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
You dont have to start the running total for each bucket. I arranged the
buckets so the ranges get the results you are looking for. The 2nd bucket is the sum is betsween 200,000 to 300,00. I can write a macro if I knew the column where the total was located, but I would use the same algorithm that I explained in my last posting. I wanted to make sure you were hapy with the algorithm before I suggested a macro. I didn't want to write the macro and then you didn't like the results. "David" wrote: Hi Joel, I really appreciate your help, however this will give me a running total on the new column where for example the first 100 records will add up to 100K, and then i would have to start the same running total to get the next bucket. Is there away that i can divide the whole 250 records into 4 buckets by pressing a button or running a macro which would base the division on the result of dcount and dsum. since i will be doing this in the future with much larger file and more than 100 buckets "Joel" wrote: Your results won't be exact but close to the results you want. 1) Sort the records by amount 2) In a new column on the 1st record that is greater or equal to $500.00 put this formula =sum(C$100:C100) Notice the dollar sign is on the first 100 only where the row number is the 1st row = 500. 3) copy formula down the worksheet. 4) Your buckets can be extract base on the new column amount bucket 1 : the totals 0 to $100,000 bucket 2 : the totals 100,000 to $200,000 bucket 3 : the totals 200,000 to $500,000 bucket 4 : the totals 500,000 to $1,000,000 bucket 5 : the totals 1,000,000 to $2,000,000 "David" wrote: Hi everyone, I have a worksheet with over 20000 records, i did a dcount based on amounts from 500-5000 and i got a result of 250 records, and dsum based on the same criteria (500-5000) i got 2,000,000. further i want to distribute the number of contracts and amount into 4 buckets as follow Dsum result 10% 10% 30% 50% total 1,000,000 100,000 100,000 300,000 500,000 1,000,000 Dcount result 10% 10% 30% 50% total 250 25 25 75 125 250 Can i somehow exctract, copy list of contracts in each bucket that will add up to the dsum amount distribution for each bucket? for example: a formula or macro that will give me 25 contracts out of 20,000 when i add the amounts it should come up to 100,000 and all contracts must be between 500-5000. I really appreciate any help i can get on this one. |
#5
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
Hi Joel,
yes you are right the data is arranged properly, however let me explain this a little further. the data that i am working with is very large, and there are multiple ranges such as 0-5K, 5K-10K, and so on, even it goes upto 1M-10M, and each range will have over 100 bucket according to their last months performance. which could be somewhere between 0.1% of each range to 50%, and the amount is not the primary key for distribution, however number of contract is. for example a bucket in 5k-10K is entitled to 3000 contract or 5% of the entire available contracts in the rage 5k-10K according his or her last months performance, and the total amount in 5k-10K times 5% will result in 5M, now i must sumbit 3K contracts to this person with the amount as close as 5M. Can i or rather you, lol write a macro that extracts 3K contracts out of 100K records with amount as close to 5K, please keep in mind the amount can come close however the number of contracts must remain the same. let me know if i have complicated this too much. "Joel" wrote: You dont have to start the running total for each bucket. I arranged the buckets so the ranges get the results you are looking for. The 2nd bucket is the sum is betsween 200,000 to 300,00. I can write a macro if I knew the column where the total was located, but I would use the same algorithm that I explained in my last posting. I wanted to make sure you were hapy with the algorithm before I suggested a macro. I didn't want to write the macro and then you didn't like the results. "David" wrote: Hi Joel, I really appreciate your help, however this will give me a running total on the new column where for example the first 100 records will add up to 100K, and then i would have to start the same running total to get the next bucket. Is there away that i can divide the whole 250 records into 4 buckets by pressing a button or running a macro which would base the division on the result of dcount and dsum. since i will be doing this in the future with much larger file and more than 100 buckets "Joel" wrote: Your results won't be exact but close to the results you want. 1) Sort the records by amount 2) In a new column on the 1st record that is greater or equal to $500.00 put this formula =sum(C$100:C100) Notice the dollar sign is on the first 100 only where the row number is the 1st row = 500. 3) copy formula down the worksheet. 4) Your buckets can be extract base on the new column amount bucket 1 : the totals 0 to $100,000 bucket 2 : the totals 100,000 to $200,000 bucket 3 : the totals 200,000 to $500,000 bucket 4 : the totals 500,000 to $1,000,000 bucket 5 : the totals 1,000,000 to $2,000,000 "David" wrote: Hi everyone, I have a worksheet with over 20000 records, i did a dcount based on amounts from 500-5000 and i got a result of 250 records, and dsum based on the same criteria (500-5000) i got 2,000,000. further i want to distribute the number of contracts and amount into 4 buckets as follow Dsum result 10% 10% 30% 50% total 1,000,000 100,000 100,000 300,000 500,000 1,000,000 Dcount result 10% 10% 30% 50% total 250 25 25 75 125 250 Can i somehow exctract, copy list of contracts in each bucket that will add up to the dsum amount distribution for each bucket? for example: a formula or macro that will give me 25 contracts out of 20,000 when i add the amounts it should come up to 100,000 and all contracts must be between 500-5000. I really appreciate any help i can get on this one. |
#6
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
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 'copy filtered data to Award sheet .Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _ Destination:=AwardSht.Cells 'remove column IV from the Award sheet AwardSht.Columns("IV").Delete End With End With With Sheets("Contracts") 'turn off autofilter If .AutoFilterMode Then .Cells.AutoFilter End If End With Application.DisplayAlerts = False End Sub "David" wrote: Hi Joel, yes you are right the data is arranged properly, however let me explain this a little further. the data that i am working with is very large, and there are multiple ranges such as 0-5K, 5K-10K, and so on, even it goes upto 1M-10M, and each range will have over 100 bucket according to their last months performance. which could be somewhere between 0.1% of each range to 50%, and the amount is not the primary key for distribution, however number of contract is. for example a bucket in 5k-10K is entitled to 3000 contract or 5% of the entire available contracts in the rage 5k-10K according his or her last months performance, and the total amount in 5k-10K times 5% will result in 5M, now i must sumbit 3K contracts to this person with the amount as close as 5M. Can i or rather you, lol write a macro that extracts 3K contracts out of 100K records with amount as close to 5K, please keep in mind the amount can come close however the number of contracts must remain the same. let me know if i have complicated this too much. "Joel" wrote: You dont have to start the running total for each bucket. I arranged the buckets so the ranges get the results you are looking for. The 2nd bucket is the sum is betsween 200,000 to 300,00. I can write a macro if I knew the column where the total was located, but I would use the same algorithm that I explained in my last posting. I wanted to make sure you were hapy with the algorithm before I suggested a macro. I didn't want to write the macro and then you didn't like the results. "David" wrote: Hi Joel, I really appreciate your help, however this will give me a running total on the new column where for example the first 100 records will add up to 100K, and then i would have to start the same running total to get the next bucket. Is there away that i can divide the whole 250 records into 4 buckets by pressing a button or running a macro which would base the division on the result of dcount and dsum. since i will be doing this in the future with much larger file and more than 100 buckets "Joel" wrote: Your results won't be exact but close to the results you want. 1) Sort the records by amount 2) In a new column on the 1st record that is greater or equal to $500.00 put this formula =sum(C$100:C100) Notice the dollar sign is on the first 100 only where the row number is the 1st row = 500. 3) copy formula down the worksheet. 4) Your buckets can be extract base on the new column amount bucket 1 : the totals 0 to $100,000 bucket 2 : the totals 100,000 to $200,000 bucket 3 : the totals 200,000 to $500,000 bucket 4 : the totals 500,000 to $1,000,000 bucket 5 : the totals 1,000,000 to $2,000,000 "David" wrote: Hi everyone, I have a worksheet with over 20000 records, i did a dcount based on amounts from 500-5000 and i got a result of 250 records, and dsum based on the same criteria (500-5000) i got 2,000,000. further i want to distribute the number of contracts and amount into 4 buckets as follow Dsum result 10% 10% 30% 50% total 1,000,000 100,000 100,000 300,000 500,000 1,000,000 Dcount result 10% 10% 30% 50% total 250 25 25 75 125 250 Can i somehow exctract, copy list of contracts in each bucket that will add up to the dsum amount distribution for each bucket? for example: a formula or macro that will give me 25 contracts out of 20,000 when i add the amounts it should come up to 100,000 and all contracts must be between 500-5000. I really appreciate any help i can get on this one. |
#7
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
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 'copy filtered data to Award sheet .Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _ Destination:=AwardSht.Cells 'remove column IV from the Award sheet AwardSht.Columns("IV").Delete End With End With With Sheets("Contracts") 'turn off autofilter If .AutoFilterMode Then .Cells.AutoFilter End If End With Application.DisplayAlerts = False End Sub "David" wrote: Hi Joel, yes you are right the data is arranged properly, however let me explain this a little further. the data that i am working with is very large, and there are multiple ranges such as 0-5K, 5K-10K, and so on, even it goes upto 1M-10M, and each range will have over 100 bucket according to their last months performance. which could be somewhere between 0.1% of each range to 50%, and the amount is not the primary key for distribution, however number of contract is. for example a bucket in 5k-10K is entitled to 3000 contract or 5% of the entire available contracts in the rage 5k-10K according his or her last months performance, and the total amount in 5k-10K times 5% will result in 5M, now i must sumbit 3K contracts to this person with the amount as close as 5M. Can i or rather you, lol write a macro that extracts 3K contracts out of 100K records with amount as close to 5K, please keep in mind the amount can come close however the number of contracts must remain the same. let me know if i have complicated this too much. "Joel" wrote: You dont have to start the running total for each bucket. I arranged the buckets so the ranges get the results you are looking for. The 2nd bucket is the sum is betsween 200,000 to 300,00. I can write a macro if I knew the column where the total was located, but I would use the same algorithm that I explained in my last posting. I wanted to make sure you were hapy with the algorithm before I suggested a macro. I didn't want to write the macro and then you didn't like the results. "David" wrote: Hi Joel, I really appreciate your help, however this will give me a running total on the new column where for example the first 100 records will add up to 100K, and then i would have to start the same running total to get the next bucket. Is there away that i can divide the whole 250 records into 4 buckets by pressing a button or running a macro which would base the division on the result of dcount and dsum. since i will be doing this in the future with much larger file and more than 100 buckets "Joel" wrote: Your results won't be exact but close to the results you want. 1) Sort the records by amount 2) In a new column on the 1st record that is greater or equal to $500.00 put this formula =sum(C$100:C100) Notice the dollar sign is on the first 100 only where the row number is the 1st row = 500. 3) copy formula down the worksheet. 4) Your buckets can be extract base on the new column amount bucket 1 : the totals 0 to $100,000 bucket 2 : the totals 100,000 to $200,000 bucket 3 : the totals 200,000 to $500,000 bucket 4 : the totals 500,000 to $1,000,000 bucket 5 : the totals 1,000,000 to $2,000,000 "David" wrote: Hi everyone, I have a worksheet with over 20000 records, i did a dcount based on amounts from 500-5000 and i got a result of 250 records, and dsum based on the same criteria (500-5000) i got 2,000,000. further i want to distribute the number of contracts and amount into 4 buckets as follow Dsum result 10% 10% 30% 50% total 1,000,000 100,000 100,000 300,000 500,000 1,000,000 Dcount result 10% 10% 30% 50% total 250 25 25 75 125 250 Can i somehow exctract, copy list of contracts in each bucket that will add up to the dsum amount distribution for each bucket? for example: a formula or macro that will give me 25 contracts out of 20,000 when i add the amounts it should come up to 100,000 and all contracts must be between 500-5000. I really appreciate any help i can get on this one. |
#8
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
Hi Joel,
You are great, i learned alot from you, however i tested the second macro, it works that way it supposed to only on the first row in awards sheet, it copies number of the contracts in a different sheet which is according to my min and max (0-5000) after creating the next sheet i get these lines highlited in yellow as an error Set AwardSht = Sheets.Add(after:=Sheets(Sheets.Count)) AwardSht.Name = shtname Thanks you very much David "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 'copy filtered data to Award sheet .Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _ Destination:=AwardSht.Cells 'remove column IV from the Award sheet AwardSht.Columns("IV").Delete End With End With With Sheets("Contracts") 'turn off autofilter If .AutoFilterMode Then .Cells.AutoFilter |
#9
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
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 'copy filtered data to Award sheet .Cells.SpecialCells(Type:=xlCellTypeVisible).Copy _ Destination:=AwardSht.Cells 'remove column IV from the Award sheet AwardSht.Columns("IV").Delete End With End With With Sheets("Contracts") 'turn off autofilter If .AutoFilterMode Then .Cells.AutoFilter |
#10
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
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 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 |
#11
Posted to microsoft.public.excel.misc
|
|||
|
|||
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 |
#12
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
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 |
#13
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
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) |
#14
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
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 |
#15
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
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 |
#16
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
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 |
#17
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
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 |
#18
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
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 |
#19
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
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 |
#20
Posted to microsoft.public.excel.misc
|
|||
|
|||
copy multiple records based on criteria or total amount
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 |
#21
Posted to microsoft.public.excel.misc
|
|||
|
|||
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
Posted to microsoft.public.excel.misc
|
|||
|
|||
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
Posted to microsoft.public.excel.misc
|
|||
|
|||
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
exclude amount from sumif total based on how many months | Excel Discussion (Misc queries) | |||
The amount calculated based on two entry criteria (somproduct?) | Excel Discussion (Misc queries) | |||
total amount based on selections of 1-9, 10-19 and 20-30 | Excel Discussion (Misc queries) | |||
sumif-add amount to another cell based on two criteria | Excel Discussion (Misc queries) | |||
Show top five records based on meeting multiple criteria | Excel Worksheet Functions |