Bottom Up search for multiple entries

H

Hans Hamm

I have not done this in a long time and cannot remember how...
Want to look in sheet 3, row D... bottom up
find each Program entry (there can be 10+ entries for the same program)
Then copy those entries (program names) and past into sheet 2 starting with cell A5.
Just cannot remember how to do it
 
B

Ben McClave

Hans,

I wrote a short macro to copy your data range to a blank column in your workbook and then use RemoveDuplicates to speed up the process. This new range of unique values is then cycled through in reverse to populate your destination list. Finally, the temporary column we added is cleared.

Hope this helps,

Ben

Sub ListPrograms()
Dim rCopy As Range 'Range of values to check
Dim rCopy2 As Range 'Blank cell at the top of an unused column
Dim x As Long 'Used for cycling through the rCopy2 range
Dim y As Long 'Used for cycling through the rPaste range
Dim rPaste As Range 'First cell to receive the data

'First, set up the copy from range and the copy/paste to range
'Application.ScreenUpdating = False 'Uncomment this line if macro runs slow

Set rCopy = Sheet3.Range("D1:D" & Sheet1.Range("D64000").End(xlUp).Row)
Set rCopy2 = Sheet1.Range("E1") 'Empty column somewhere in your workbook
Set rPaste = Sheet2.Range("A5")

y = 0 'Set to zero to start

'Next, resize the rCopy2 range to match the rCopy range size and copy the data
Set rCopy2 = rCopy2.Resize(rCopy.Rows.Count, 1)
rCopy.Copy rCopy2

'Now, remove duplicates (assumes no headers)
rCopy2.RemoveDuplicates 1, xlNo

'Once again resize rCopy2 to cover reduced data range
'**(Check next line to ensure that the sheet name and column are correct)
Set rCopy2 = Sheet1.Range("E1:E" & Sheet1.Range("E64000").End(xlUp).Row)

'Now, cycle through each value in rCopy2 starting from the bottom _
and paste it to the final destination.
For x = rCopy2.Rows.Count To 1 Step -1
rPaste.Offset(y, 0).Value = rCopy2.Cells(x, 1)
y = y + 1 'Increment y to ensure next value goes into the cell below
Next x

'Finally, clear the rCopy2 range as it is no longer necessary.
rCopy2.Clear
Application.ScreenUpdating = True

End Sub
 
H

Hans Hamm

Hans,



I wrote a short macro to copy your data range to a blank column in your workbook and then use RemoveDuplicates to speed up the process. This new range of unique values is then cycled through in reverse to populate your destination list. Finally, the temporary column we added is cleared.



Hope this helps,



Ben



Sub ListPrograms()

Dim rCopy As Range 'Range of values to check

Dim rCopy2 As Range 'Blank cell at the top of an unused column

Dim x As Long 'Used for cycling through the rCopy2 range

Dim y As Long 'Used for cycling through the rPaste range

Dim rPaste As Range 'First cell to receive the data



'First, set up the copy from range and the copy/paste to range

'Application.ScreenUpdating = False 'Uncomment this line if macro runsslow



Set rCopy = Sheet3.Range("D1:D" & Sheet1.Range("D64000").End(xlUp).Row)

Set rCopy2 = Sheet1.Range("E1") 'Empty column somewhere in your workbook

Set rPaste = Sheet2.Range("A5")



y = 0 'Set to zero to start



'Next, resize the rCopy2 range to match the rCopy range size and copy thedata

Set rCopy2 = rCopy2.Resize(rCopy.Rows.Count, 1)

rCopy.Copy rCopy2



'Now, remove duplicates (assumes no headers)

rCopy2.RemoveDuplicates 1, xlNo



'Once again resize rCopy2 to cover reduced data range

'**(Check next line to ensure that the sheet name and column are correct)

Set rCopy2 = Sheet1.Range("E1:E" & Sheet1.Range("E64000").End(xlUp)..Row)



'Now, cycle through each value in rCopy2 starting from the bottom _

and paste it to the final destination.

For x = rCopy2.Rows.Count To 1 Step -1

rPaste.Offset(y, 0).Value = rCopy2.Cells(x, 1)

y = y + 1 'Increment y to ensure next value goes into the cell below

Next x



'Finally, clear the rCopy2 range as it is no longer necessary.

rCopy2.Clear

Application.ScreenUpdating = True



End Sub

Ben, Cool...one little tweek and it worked DEAD ON!Had to change "Sheet3.Range("D1:D...." to D2 as I have headers.Thanks for the help. I have not doneany of this in 8-9 years and just cannot remember any of it. So I may be reaching out again for some assistance.
 
C

Claus Busch

Hi Hans,

Am Wed, 10 Oct 2012 07:37:42 -0700 (PDT) schrieb Hans Hamm:
Want to look in sheet 3, row D... bottom up
find each Program entry (there can be 10+ entries for the same program)
Then copy those entries (program names) and past into sheet 2 starting with cell A5.

try:
Sheets("Sheet3").Columns("D:D").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Sheets("Sheet2").Range("A5"), Unique:=True


Regards
Claus Busch
 
H

Hans Hamm

Hans,



I'm glad to hear that it worked for you. Thanks for the feedback.



Ben

Now have an additional one for you....
You provided this code:
Set rPaste = Sheet2.Range("A5")

I have found I need the same information in an additional location, specifically Sheet2 starting in cell A36.
Tried three different ways
Set rPaste2 = Sheet2.Range("A36")
Set rPaste = Sheet2.Range("A5")&("A36")
Set rPaste = Sheet2.Range("A5", "A36")
Neither works... how would I do this?
 
B

Ben McClave

Hans,

I've modified this a bit to do this for you. Please note I haven't tested it. Let me know if you have any issues with it.

Ben

Sub ListPrograms()
Dim rCopy As Range 'Range of values to check
Dim rCopy2 As Range 'Blank cell at the top of an unused column
Dim x As Long 'Used for cycling through the rCopy2 range
Dim y As Long 'Used for cycling through the rPaste range
Dim rPaste(1 to 2) As Range 'First cell to receive the data

'First, set up the copy from range and the copy/paste to range
'Application.ScreenUpdating = False 'Uncomment this line if macro runs slow

Set rCopy = Sheet3.Range("D2:D" & Sheet1.Range("D64000").End(xlUp).Row)
Set rCopy2 = Sheet1.Range("E1") 'Empty column somewhere in your workbook
Set rPaste(1) = Sheet2.Range("A5")
Set rPaste(2) = Sheet2.Range("A36")

y = 0 'Set to zero to start

'Next, resize the rCopy2 range to match the rCopy range size and copy the data
Set rCopy2 = rCopy2.Resize(rCopy.Rows.Count, 1)
rCopy.Copy rCopy2

'Now, remove duplicates (assumes no headers)
rCopy2.RemoveDuplicates 1, xlNo

'Once again resize rCopy2 to cover reduced data range
'**(Check next line to ensure that the sheet name and column are correct)
Set rCopy2 = Sheet1.Range("E1:E" & Sheet1.Range("E64000").End(xlUp).Row)

'Now, cycle through each value in rCopy2 starting from the bottom _
and paste it to the final destination.
For x = rCopy2.Rows.Count To 1 Step -1
rPaste(1).Offset(y, 0).Value = rCopy2.Cells(x, 1)
rPaste(2).Offset(y, 0).Value = rCopy2.Cells(x, 1)
y = y + 1 'Increment y to ensure next value goes into the cell below
Next x

'Finally, clear the rCopy2 range as it is no longer necessary.
rCopy2.Clear
Application.ScreenUpdating = True

End Sub
 
H

Hans Hamm

Hans,



I've modified this a bit to do this for you. Please note I haven't tested it. Let me know if you have any issues with it.



Ben



Sub ListPrograms()

Dim rCopy As Range 'Range of values to check

Dim rCopy2 As Range 'Blank cell at the top of an unused column

Dim x As Long 'Used for cycling through the rCopy2 range

Dim y As Long 'Used for cycling through the rPaste range

Dim rPaste(1 to 2) As Range 'First cell to receive the data



'First, set up the copy from range and the copy/paste to range

'Application.ScreenUpdating = False 'Uncomment this line if macro runs slow



Set rCopy = Sheet3.Range("D2:D" & Sheet1.Range("D64000").End(xlUp).Row)

Set rCopy2 = Sheet1.Range("E1") 'Empty column somewhere in your workbook

Set rPaste(1) = Sheet2.Range("A5")

Set rPaste(2) = Sheet2.Range("A36")



y = 0 'Set to zero to start



'Next, resize the rCopy2 range to match the rCopy range size and copy the data

Set rCopy2 = rCopy2.Resize(rCopy.Rows.Count, 1)

rCopy.Copy rCopy2



'Now, remove duplicates (assumes no headers)

rCopy2.RemoveDuplicates 1, xlNo



'Once again resize rCopy2 to cover reduced data range

'**(Check next line to ensure that the sheet name and column are correct)

Set rCopy2 = Sheet1.Range("E1:E" & Sheet1.Range("E64000").End(xlUp).Row)



'Now, cycle through each value in rCopy2 starting from the bottom _

and paste it to the final destination.

For x = rCopy2.Rows.Count To 1 Step -1

rPaste(1).Offset(y, 0).Value = rCopy2.Cells(x, 1)

rPaste(2).Offset(y, 0).Value = rCopy2.Cells(x, 1)

y = y + 1 'Increment y to ensure next value goes into the cell below

Next x



'Finally, clear the rCopy2 range as it is no longer necessary.

rCopy2.Clear

Application.ScreenUpdating = True



End Sub

Ah Ha! So, that is how you repeat a process with "Dim rPaste(1 To 2)" I could not figure out how to do that without repeating the entire process. Thanks! I am sure I will have additional questions for you when I hit the "wall" I do appreciate your help.
 
H

Hans Hamm

Ah Ha! So, that is how you repeat a process with "Dim rPaste(1 To 2)" I could not figure out how to do that without repeating the entire process. Thanks! I am sure I will have additional questions for you when I hit the "wall" I do appreciate your help.

Ben, don't know if you are still seeing this, but I have a question for you.. I am using (adapted a little) the code you provided in a different workbook and repeating the same process over and again looking for different information and it works to perfection! At the end of each section of code I need it to skip 2 rows and repeat the process (looking for different information from another column) How do I make this work?
 
H

Hans Hamm

Ben, don't know if you are still seeing this, but I have a question for you. I am using (adapted a little) the code you provided in a different workbook and repeating the same process over and again looking for different information and it works to perfection! At the end of each section of code I need it to skip 2 rows and repeat the process (looking for different information from another column) How do I make this work?

I should have added; while most everything is working I am now trying to clean it up and automate more...
 
B

Ben McClave

Hans,

I'm having trouble picturing what you would like to change. Would you mindposting the code you're using and insert comments where you would like thechanges to occur?

As I understand it, the code currently cycles through each unique value in column D and pastes them in reverse order to two separate places. When yousay "skip 2 rows", do you mean to skip down 2 rows from where the unique values were pasted (i.e. "rPaste(1)" or "rPaste(2)" + 2 rows)? And is thereany pattern to the next column to check (i.e. check column D then E then Fetc.)?

Thanks,
Ben
 
H

Hans Hamm

Hans,



I'm having trouble picturing what you would like to change. Would you mind posting the code you're using and insert comments where you would like the changes to occur?



As I understand it, the code currently cycles through each unique value in column D and pastes them in reverse order to two separate places. When you say "skip 2 rows", do you mean to skip down 2 rows from where the uniquevalues were pasted (i.e. "rPaste(1)" or "rPaste(2)" + 2 rows)? And is there any pattern to the next column to check (i.e. check column D then E thenF etc.)?



Thanks,

Ben

I actually have used your basic code 7-8 times in this report to provide data on different sections. I have for example a team section, store section,reason code section etc...
After the code you provided and the "sumproduct formula" to pull the #'s that correspond to each individual call in each section.
I will place "my needs" in **CAPS** inside the lines of code below

The section below is static and does not change, for your reference for date ranges also...

'STARTS OVERALL & TEAM DATA SECTION
Dim rng1 As Range 'Total # Of Calls
Dim rng2 As Range '# Of Closed Calls
Dim rng3 As Range '# Of Pending Calls
Dim rng4 As Range '# Of Open Calls


Set rng1 = Sheet1.Range("B3")
Set rng2 = Sheet1.Range("C3")
Set rng3 = Sheet1.Range("D3")
Set rng4 = Sheet1.Range("E3")

With rng1
.Formula = "=SUMPRODUCT((Sheet2!AJ2:AJ2000>=Sheet1!C1)*(Sheet2!AJ2:AJ2000<=Sheet1!E1))"
.Value = .Value
End With

With rng2
.Formula = "=SUMPRODUCT((Sheet2!AJ2:AJ2000>=Sheet1!C1)*(Sheet2!AJ2:AJ2000<=Sheet1!E1)*(Sheet2!G2:G2000=""Closed""))"
.Value = .Value
End With

With rng3
.Formula = "=SUMPRODUCT((Sheet2!AJ2:AJ2000>=Sheet1!C1)*(Sheet2!AJ2:AJ2000<=Sheet1!E1)*(Sheet2!G2:G2000=""Pending""))"
.Value = .Value
End With

With rng4
.Formula = "=SUMPRODUCT((Sheet2!AJ2:AJ2000>=Sheet1!C1)*(Sheet2!AJ2:AJ2000<=Sheet1!E1)*(Sheet2!G2:G2000=""Open""))"
.Value = .Value
End With
**EVERYTHING ELSE BELOW IS SUBJECT TO CHANGE BASED ON THE DATE RANGES IN LOCATED IN CELLS C1 (START DATE) AND E1 (END DATE)
SO, I NEED THE CODE YOU PROVIDED TO BE ENHANCED BY LOOKING AT THE DATE RANGE AND ONLY RETURN THOSE WHICH FALL WITHIN THAT RANGE**


'STARTS STORE DATA SECTION

**THIS IS LAYMAN SPEAK HERE: IF THE DATE IN SHEET2 COLUMN AJ IS >= SHEET1CELL C1 (START DATE) AND IF THE DATE IN SHEET2 COLUMN AJ IS <= SHEET E1 (END DATE)
THEN FIND ALL RCOPY ITEMS THAT FALL WITHIN THAT DATE RANGE. I WILL TRY AND GIVE THIS AGAIN AT THE RCOPY LINE BELOW***

Dim rCopy As Range 'Range of values to check
Dim rCopy2 As Range 'Blank cell at the top of an unused column
Dim x As Long 'Used for cycling through the rCopy2 range
Dim y As Long 'Used for cycling through the rPaste range
Dim rPaste As Range 'First cell to receive the data

'First, set up the copy from range and the copy/paste to range
'Application.ScreenUpdating = False 'Uncomment this line if macro runs slow

IF SHEET2.RANGE("AJ2:AJ") >= SHEET1.RANGE("C1") AND SHEET2.RANGE("AJ2:AJ"),= SHEET1.RANGE("E1")
THEN
Set rCopy = Sheet2.Range("H2:H" & lastRow)
Set rCopy2 = Sheet1.Range("AB1") 'Empty column somewhere in your workbook
Set rPaste = Sheet1.Range("A10")

y = 0 'Set to zero to start

'Next, resize the rCopy2 range to match the rCopy range size and copy the data
Set rCopy2 = rCopy2.Resize(rCopy.Rows.Count, 1)
rCopy.Copy rCopy2

'Now, remove duplicates (assumes no headers)
rCopy2.RemoveDuplicates 1, xlNo

'Once again resize rCopy2 to cover reduced data range
'**(Check next line to ensure that the sheet name and column are correct)
Set rCopy2 = Sheet1.Range("AB1:AB" & Sheet1.Range("AB64000").End(xlUp).Row)

'Now, cycle through each value in rCopy2 starting from the bottom _
and paste it to the final destination.
For x = rCopy2.Rows.Count To 1 Step -1
rPaste.Offset(y, 0).Value = rCopy2.Cells(x, 1)
y = y + 1 'Increment y to ensure next value goes into the cell below
Next x

'Finally, clear the rCopy2 range as it is no longer necessary.
rCopy2.Clear
Application.ScreenUpdating = True

THIS NOW GIVES ME ALL THE STORE POSITIONS THAT HAVE CALLED IN COLUMN A
THE NEXT SECTION GIVES ME THE # OF CALLS, CLOSED CALLS, PENDING CALLS ETC....


'Store # OF Calls

With Sheet1.Range("B10:B22")
..Formula = "=SUMPRODUCT((Sheet2!AJ$2:AJ$2000>=Sheet1!C$1)*(Sheet2!AJ$2:AJ$2000<=Sheet1!E$1)*(Sheet2!H$2:H$2000=Sheet1!A10))"
..Value = .Value
End With

'Store Closed Calls
With Sheet1.Range("C10:C22")
..Formula = "=SUMPRODUCT((Sheet2!AJ$2:AJ$2000>=Sheet1!C$1)*(Sheet2!AJ$2:AJ$2000<=Sheet1!E$1)*(Sheet2!H$2:H$2000=Sheet1!A10)*(Sheet2!G$2:G$2000=""Closed""))"
..Value = .Value
End With

'Store Pending Calls
With Sheet1.Range("D10:D22")
..Formula = "=SUMPRODUCT((Sheet2!AJ$2:AJ$2000>=Sheet1!C$1)*(Sheet2!AJ$2:AJ$2000<=Sheet1!E$1)*(Sheet2!H$2:H$2000=Sheet1!A10)*(Sheet2!G$2:G$2000=""Pending""))"
..Value = .Value
End With

'Store Open Calls
With Sheet1.Range("E10:E22")
..Formula = "=SUMPRODUCT((Sheet2!AJ$2:AJ$2000>=Sheet1!C$1)*(Sheet2!AJ$2:AJ$2000<=Sheet1!E$1)*(Sheet2!H$2:H$2000=Sheet1!A10)*(Sheet2!G$2:G$2000=""Open""))"
..Value = .Value
End With

****AFTER THIS HAS BEEN COMPLETED I NEED IT TO SKIP TWO ROWS DOWN AND STARTA NEW SECTION.*** BASICALLY REPEATING THIS ENTIRE PROCESS AGAIN.

If you cannot make sense of my gibberish I can send you the workbook if it will help.
Thanks Ben!!!
 
H

Hans Hamm

I actually have used your basic code 7-8 times in this report to provide data on different sections. I have for example a team section, store section, reason code section etc...

After the code you provided and the "sumproduct formula" to pull the #'s that correspond to each individual call in each section.

I will place "my needs" in **CAPS** inside the lines of code below



The section below is static and does not change, for your reference for date ranges also...



'STARTS OVERALL & TEAM DATA SECTION

Dim rng1 As Range 'Total # Of Calls

Dim rng2 As Range '# Of Closed Calls

Dim rng3 As Range '# Of Pending Calls

Dim rng4 As Range '# Of Open Calls





Set rng1 = Sheet1.Range("B3")

Set rng2 = Sheet1.Range("C3")

Set rng3 = Sheet1.Range("D3")

Set rng4 = Sheet1.Range("E3")



With rng1

.Formula = "=SUMPRODUCT((Sheet2!AJ2:AJ2000>=Sheet1!C1)*(Sheet2!AJ2:AJ2000<=Sheet1!E1))"

.Value = .Value

End With



With rng2

.Formula = "=SUMPRODUCT((Sheet2!AJ2:AJ2000>=Sheet1!C1)*(Sheet2!AJ2:AJ2000<=Sheet1!E1)*(Sheet2!G2:G2000=""Closed""))"

.Value = .Value

End With



With rng3

.Formula = "=SUMPRODUCT((Sheet2!AJ2:AJ2000>=Sheet1!C1)*(Sheet2!AJ2:AJ2000<=Sheet1!E1)*(Sheet2!G2:G2000=""Pending""))"

.Value = .Value

End With



With rng4

.Formula = "=SUMPRODUCT((Sheet2!AJ2:AJ2000>=Sheet1!C1)*(Sheet2!AJ2:AJ2000<=Sheet1!E1)*(Sheet2!G2:G2000=""Open""))"

.Value = .Value

End With

**EVERYTHING ELSE BELOW IS SUBJECT TO CHANGE BASED ON THE DATE RANGES IN LOCATED IN CELLS C1 (START DATE) AND E1 (END DATE)

SO, I NEED THE CODE YOU PROVIDED TO BE ENHANCED BY LOOKING AT THE DATE RANGE AND ONLY RETURN THOSE WHICH FALL WITHIN THAT RANGE**





'STARTS STORE DATA SECTION



**THIS IS LAYMAN SPEAK HERE: IF THE DATE IN SHEET2 COLUMN AJ IS >= SHEET1 CELL C1 (START DATE) AND IF THE DATE IN SHEET2 COLUMN AJ IS <= SHEET E1 (END DATE)

THEN FIND ALL RCOPY ITEMS THAT FALL WITHIN THAT DATE RANGE. I WILL TRY AND GIVE THIS AGAIN AT THE RCOPY LINE BELOW***



Dim rCopy As Range 'Range of values to check

Dim rCopy2 As Range 'Blank cell at the top of an unused column

Dim x As Long 'Used for cycling through the rCopy2 range

Dim y As Long 'Used for cycling through the rPaste range

Dim rPaste As Range 'First cell to receive the data



'First, set up the copy from range and the copy/paste to range

'Application.ScreenUpdating = False 'Uncomment this line if macro runsslow



IF SHEET2.RANGE("AJ2:AJ") >= SHEET1.RANGE("C1") AND SHEET2.RANGE("AJ2:AJ"),= SHEET1.RANGE("E1")

THEN

Set rCopy = Sheet2.Range("H2:H" & lastRow)

Set rCopy2 = Sheet1.Range("AB1") 'Empty column somewhere in your workbook

Set rPaste = Sheet1.Range("A10")



y = 0 'Set to zero to start



'Next, resize the rCopy2 range to match the rCopy range size and copy thedata

Set rCopy2 = rCopy2.Resize(rCopy.Rows.Count, 1)

rCopy.Copy rCopy2



'Now, remove duplicates (assumes no headers)

rCopy2.RemoveDuplicates 1, xlNo



'Once again resize rCopy2 to cover reduced data range

'**(Check next line to ensure that the sheet name and column are correct)

Set rCopy2 = Sheet1.Range("AB1:AB" & Sheet1.Range("AB64000").End(xlUp).Row)



'Now, cycle through each value in rCopy2 starting from the bottom _

and paste it to the final destination.

For x = rCopy2.Rows.Count To 1 Step -1

rPaste.Offset(y, 0).Value = rCopy2.Cells(x, 1)

y = y + 1 'Increment y to ensure next value goes into the cell below

Next x



'Finally, clear the rCopy2 range as it is no longer necessary.

rCopy2.Clear

Application.ScreenUpdating = True



THIS NOW GIVES ME ALL THE STORE POSITIONS THAT HAVE CALLED IN COLUMN A

THE NEXT SECTION GIVES ME THE # OF CALLS, CLOSED CALLS, PENDING CALLS ETC....





'Store # OF Calls



With Sheet1.Range("B10:B22")

.Formula = "=SUMPRODUCT((Sheet2!AJ$2:AJ$2000>=Sheet1!C$1)*(Sheet2!AJ$2:AJ$2000<=Sheet1!E$1)*(Sheet2!H$2:H$2000=Sheet1!A10))"

.Value = .Value

End With



'Store Closed Calls

With Sheet1.Range("C10:C22")

.Formula = "=SUMPRODUCT((Sheet2!AJ$2:AJ$2000>=Sheet1!C$1)*(Sheet2!AJ$2:AJ$2000<=Sheet1!E$1)*(Sheet2!H$2:H$2000=Sheet1!A10)*(Sheet2!G$2:G$2000=""Closed""))"

.Value = .Value

End With



'Store Pending Calls

With Sheet1.Range("D10:D22")

.Formula = "=SUMPRODUCT((Sheet2!AJ$2:AJ$2000>=Sheet1!C$1)*(Sheet2!AJ$2:AJ$2000<=Sheet1!E$1)*(Sheet2!H$2:H$2000=Sheet1!A10)*(Sheet2!G$2:G$2000=""Pending""))"

.Value = .Value

End With



'Store Open Calls

With Sheet1.Range("E10:E22")

.Formula = "=SUMPRODUCT((Sheet2!AJ$2:AJ$2000>=Sheet1!C$1)*(Sheet2!AJ$2:AJ$2000<=Sheet1!E$1)*(Sheet2!H$2:H$2000=Sheet1!A10)*(Sheet2!G$2:G$2000=""Open""))"

.Value = .Value

End With



****AFTER THIS HAS BEEN COMPLETED I NEED IT TO SKIP TWO ROWS DOWN AND START A NEW SECTION.*** BASICALLY REPEATING THIS ENTIRE PROCESS AGAIN.



If you cannot make sense of my gibberish I can send you the workbook if it will help.

Thanks Ben!!!

Ben an additional point I guess I should make and this is what I am head scratching about... if, for example this month the Store Data section contains 5 listings say (A5:A10), but next month it contains 10. I need the code you provided to expand to the 10 (A5:A15), which it does. But, also how do Iget the sumproduct formulas to work within that "new" range from A5:A10 toA5:A15?
 
B

Ben McClave

Hans,

The code I wrote (below) is not pretty, but I think that it will do the trick. Give it a try and see if this helps.

Ben

'STARTS OVERALL & TEAM DATA SECTION
Dim rng1 As Range 'Total # Of Calls
Dim rng2 As Range '# Of Closed Calls
Dim rng3 As Range '# Of Pending Calls
Dim rng4 As Range '# Of Open Calls

'Uncomment next line to delete prior month's data (rows 3 and down)
'Sheet1.Range("3:" & Sheet1.UsedRange.Rows.Count).ClearContents

Set rng1 = Sheet1.Range("B3")
Set rng2 = Sheet1.Range("C3")
Set rng3 = Sheet1.Range("D3")
Set rng4 = Sheet1.Range("E3")

With rng1
.Formula = "=SUMPRODUCT((Sheet2!AJ2:AJ2000>=Sheet1!C1)*(Sheet2!AJ2:AJ2000<=Sheet1!E1))"
.Value = .Value
End With

With rng2
.Formula = "=SUMPRODUCT((Sheet2!AJ2:AJ2000>=Sheet1!C1)*(Sheet2!AJ2:AJ2000<=Sheet1!E1)*(Sheet2!G2:G2000=""Closed""))"
.Value = .Value
End With

With rng3
.Formula = "=SUMPRODUCT((Sheet2!AJ2:AJ2000>=Sheet1!C1)*(Sheet2!AJ2:AJ2000<=Sheet1!E1)*(Sheet2!G2:G2000=""Pending""))"
.Value = .Value
End With

With rng4
.Formula = "=SUMPRODUCT((Sheet2!AJ2:AJ2000>=Sheet1!C1)*(Sheet2!AJ2:AJ2000<=Sheet1!E1)*(Sheet2!G2:G2000=""Open""))"
.Value = .Value
End With
'**EVERYTHING ELSE BELOW IS SUBJECT TO CHANGE BASED ON THE DATE RANGES IN LOCATED IN CELLS C1 (START DATE) AND E1 (END DATE)
' SO, I NEED THE CODE YOU PROVIDED TO BE ENHANCED BY LOOKING AT THE DATE RANGE AND ONLY RETURN THOSE WHICH FALL WITHIN THAT RANGE**


'STARTS STORE DATA SECTION

'**THIS IS LAYMAN SPEAK HERE: IF THE DATE IN SHEET2 COLUMN AJ IS >= SHEET1 CELL C1 (START DATE) AND IF THE DATE IN SHEET2 COLUMN AJ IS <= SHEET E1 (END DATE)
' THEN FIND ALL RCOPY ITEMS THAT FALL WITHIN THAT DATE RANGE. I WILL TRY AND GIVE THIS AGAIN AT THE RCOPY LINE BELOW***

Dim wsNew As Worksheet 'New worksheet for data manipulation
Dim rCopy As Range 'Range of values to check
Dim rCopy2 As Range 'Blank cell at the top of an unused column
Dim rCheck As Range 'Range of dates to check
Dim x As Long 'Used for cycling through the rCopy2 range
Dim y As Long 'Used for cycling through the rPaste range
Dim lastRow As Long 'Last row in column
Dim rPaste As Range 'First cell to receive the data

'First, set up the copy from range and the copy/paste to range
'Application.ScreenUpdating = False 'Uncomment this line if macro runs slow


'IF SHEET2.RANGE("AJ2:AJ") >= SHEET1.RANGE("C1") AND SHEET2.RANGE("AJ2:AJ"),= SHEET1.RANGE("E1") _
THEN
lastRow = Sheet2.Range("H50000").End(xlUp).Row
Set wsNew = Worksheets.Add
Set rCopy = Sheet2.Range("H1:AJ" & lastRow) 'Be sure to include both the data you want and the date here with column headings.
Set rCheck = Sheet2.Range("AJ2:AJ" & Sheet2.Range("AJ50000").End(xlUp).Row)
Set rPaste = Sheet1.Range("A10")


'Prepare criteria for the search
With wsNew
.Range("A1:B1").Value = rCheck.Offset(-1).Value
.Range("A2").FormulaR1C1 = "="">="" & Sheet1!R1C3"
.Range("B2").FormulaR1C1 = "=""<="" & Sheet1!R1C5"
.Range("A2:B2").Value = .Range("A2:B2").Value
Set rCopy2 = .Range("G1")
rCopy2.Value = rCopy.Value
rCopy.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("A1:B2"), CopyToRange:=rCopy2, Unique:=True
End With

y = 0 'Set to zero to start

'Next, resize the rCopy2 range to match the rCopy range size
Set rCopy2 = rCopy2.Resize(wsNew.UsedRange.Rows.Count, 1)

'Now, cycle through each value in rCopy2 starting from the bottom _
and paste it to the final destination.
Dim lRows As Long
lRows = rCopy2.Rows.Count
For x = lRows To 2 Step -1

rPaste.Offset(y, 0).Value = rCopy2.Cells(x, 1)

y = y + 1 'Increment y to ensure next value goes into the cell below
Next x

'Finally, delete the wsNew sheet as it is no longer necessary.
Application.DisplayAlerts = False
wsNew.Delete
Application.DisplayAlerts = True


'THIS NOW GIVES ME ALL THE STORE POSITIONS THAT HAVE CALLED IN COLUMN A
'THE NEXT SECTION GIVES ME THE # OF CALLS, CLOSED CALLS, PENDING CALLS ETC...


'Store # OF Calls
lRows = lRows + 8
With Sheet1.Range("B10:B" & lRows)
..Formula = "=SUMPRODUCT((Sheet2!AJ$2:AJ$2000>=Sheet1!C$1)*(Sheet2!AJ$2:AJ$2000<=Sheet1!E$1)*(Sheet2!H$2:H$2000=Sheet1!A10))"
'.Value = .Value
End With

'Store Closed Calls
With Sheet1.Range("C10:C" & lRows)
..Formula = "=SUMPRODUCT((Sheet2!AJ$2:AJ$2000>=Sheet1!C$1)*(Sheet2!AJ$2:AJ$2000<=Sheet1!E$1)*(Sheet2!H$2:H$2000=Sheet1!A10)*(Sheet2!G$2:G$2000=""Closed""))"
'.Value = .Value
End With

'Store Pending Calls
With Sheet1.Range("D10:D" & lRows)
..Formula = "=SUMPRODUCT((Sheet2!AJ$2:AJ$2000>=Sheet1!C$1)*(Sheet2!AJ$2:AJ$2000<=Sheet1!E$1)*(Sheet2!H$2:H$2000=Sheet1!A10)*(Sheet2!G$2:G$2000=""Pending""))"
'.Value = .Value
End With

'Store Open Calls
With Sheet1.Range("E10:E" & lRows)
..Formula = "=SUMPRODUCT((Sheet2!AJ$2:AJ$2000>=Sheet1!C$1)*(Sheet2!AJ$2:AJ$2000<=Sheet1!E$1)*(Sheet2!H$2:H$2000=Sheet1!A10)*(Sheet2!G$2:G$2000=""Open""))"
'.Value = .Value
End With

'Copies the data and pastes it two rows down
Sheet1.Range("10:" & lRows).Copy Sheet1.Range(lRows + 3 & ":" & lRows + 3)
Application.ScreenUpdating = True
 
H

Hans Hamm

Hans,



The code I wrote (below) is not pretty, but I think that it will do the trick. Give it a try and see if this helps.



Ben



'STARTS OVERALL & TEAM DATA SECTION

Dim rng1 As Range 'Total # Of Calls

Dim rng2 As Range '# Of Closed Calls

Dim rng3 As Range '# Of Pending Calls

Dim rng4 As Range '# Of Open Calls



'Uncomment next line to delete prior month's data (rows 3 and down)

'Sheet1.Range("3:" & Sheet1.UsedRange.Rows.Count).ClearContents



Set rng1 = Sheet1.Range("B3")

Set rng2 = Sheet1.Range("C3")

Set rng3 = Sheet1.Range("D3")

Set rng4 = Sheet1.Range("E3")



With rng1

.Formula = "=SUMPRODUCT((Sheet2!AJ2:AJ2000>=Sheet1!C1)*(Sheet2!AJ2:AJ2000<=Sheet1!E1))"

.Value = .Value

End With



With rng2

.Formula = "=SUMPRODUCT((Sheet2!AJ2:AJ2000>=Sheet1!C1)*(Sheet2!AJ2:AJ2000<=Sheet1!E1)*(Sheet2!G2:G2000=""Closed""))"

.Value = .Value

End With



With rng3

.Formula = "=SUMPRODUCT((Sheet2!AJ2:AJ2000>=Sheet1!C1)*(Sheet2!AJ2:AJ2000<=Sheet1!E1)*(Sheet2!G2:G2000=""Pending""))"

.Value = .Value

End With



With rng4

.Formula = "=SUMPRODUCT((Sheet2!AJ2:AJ2000>=Sheet1!C1)*(Sheet2!AJ2:AJ2000<=Sheet1!E1)*(Sheet2!G2:G2000=""Open""))"

.Value = .Value

End With

'**EVERYTHING ELSE BELOW IS SUBJECT TO CHANGE BASED ON THE DATE RANGES INLOCATED IN CELLS C1 (START DATE) AND E1 (END DATE)

' SO, I NEED THE CODE YOU PROVIDED TO BE ENHANCED BY LOOKING AT THE DATE RANGE AND ONLY RETURN THOSE WHICH FALL WITHIN THAT RANGE**





'STARTS STORE DATA SECTION



'**THIS IS LAYMAN SPEAK HERE: IF THE DATE IN SHEET2 COLUMN AJ IS >= SHEET1 CELL C1 (START DATE) AND IF THE DATE IN SHEET2 COLUMN AJ IS <= SHEET E1 (END DATE)

' THEN FIND ALL RCOPY ITEMS THAT FALL WITHIN THAT DATE RANGE. I WILL TRY AND GIVE THIS AGAIN AT THE RCOPY LINE BELOW***



Dim wsNew As Worksheet 'New worksheet for data manipulation

Dim rCopy As Range 'Range of values to check

Dim rCopy2 As Range 'Blank cell at the top of an unused column

Dim rCheck As Range 'Range of dates to check

Dim x As Long 'Used for cycling through the rCopy2 range

Dim y As Long 'Used for cycling through the rPaste range

Dim lastRow As Long 'Last row in column

Dim rPaste As Range 'First cell to receive the data



'First, set up the copy from range and the copy/paste to range

'Application.ScreenUpdating = False 'Uncomment this line if macro runsslow





'IF SHEET2.RANGE("AJ2:AJ") >= SHEET1.RANGE("C1") AND SHEET2.RANGE("AJ2:AJ"),= SHEET1.RANGE("E1") _

THEN

lastRow = Sheet2.Range("H50000").End(xlUp).Row

Set wsNew = Worksheets.Add

Set rCopy = Sheet2.Range("H1:AJ" & lastRow) 'Be sure to include both the data you want and the date here with column headings.

Set rCheck = Sheet2.Range("AJ2:AJ" & Sheet2.Range("AJ50000").End(xlUp).Row)

Set rPaste = Sheet1.Range("A10")





'Prepare criteria for the search

With wsNew

.Range("A1:B1").Value = rCheck.Offset(-1).Value

.Range("A2").FormulaR1C1 = "="">="" & Sheet1!R1C3"

.Range("B2").FormulaR1C1 = "=""<="" & Sheet1!R1C5"

.Range("A2:B2").Value = .Range("A2:B2").Value

Set rCopy2 = .Range("G1")

rCopy2.Value = rCopy.Value

rCopy.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("A1:B2"), CopyToRange:=rCopy2, Unique:=True

End With



y = 0 'Set to zero to start



'Next, resize the rCopy2 range to match the rCopy range size

Set rCopy2 = rCopy2.Resize(wsNew.UsedRange.Rows.Count, 1)



'Now, cycle through each value in rCopy2 starting from the bottom _

and paste it to the final destination.

Dim lRows As Long

lRows = rCopy2.Rows.Count

For x = lRows To 2 Step -1



rPaste.Offset(y, 0).Value = rCopy2.Cells(x, 1)



y = y + 1 'Increment y to ensure next value goes into the cell below

Next x



'Finally, delete the wsNew sheet as it is no longer necessary.

Application.DisplayAlerts = False

wsNew.Delete

Application.DisplayAlerts = True





'THIS NOW GIVES ME ALL THE STORE POSITIONS THAT HAVE CALLED IN COLUMN A

'THE NEXT SECTION GIVES ME THE # OF CALLS, CLOSED CALLS, PENDING CALLS ETC...





'Store # OF Calls

lRows = lRows + 8

With Sheet1.Range("B10:B" & lRows)

.Formula = "=SUMPRODUCT((Sheet2!AJ$2:AJ$2000>=Sheet1!C$1)*(Sheet2!AJ$2:AJ$2000<=Sheet1!E$1)*(Sheet2!H$2:H$2000=Sheet1!A10))"

'.Value = .Value

End With



'Store Closed Calls

With Sheet1.Range("C10:C" & lRows)

.Formula = "=SUMPRODUCT((Sheet2!AJ$2:AJ$2000>=Sheet1!C$1)*(Sheet2!AJ$2:AJ$2000<=Sheet1!E$1)*(Sheet2!H$2:H$2000=Sheet1!A10)*(Sheet2!G$2:G$2000=""Closed""))"

'.Value = .Value

End With



'Store Pending Calls

With Sheet1.Range("D10:D" & lRows)

.Formula = "=SUMPRODUCT((Sheet2!AJ$2:AJ$2000>=Sheet1!C$1)*(Sheet2!AJ$2:AJ$2000<=Sheet1!E$1)*(Sheet2!H$2:H$2000=Sheet1!A10)*(Sheet2!G$2:G$2000=""Pending""))"

'.Value = .Value

End With



'Store Open Calls

With Sheet1.Range("E10:E" & lRows)

.Formula = "=SUMPRODUCT((Sheet2!AJ$2:AJ$2000>=Sheet1!C$1)*(Sheet2!AJ$2:AJ$2000<=Sheet1!E$1)*(Sheet2!H$2:H$2000=Sheet1!A10)*(Sheet2!G$2:G$2000=""Open""))"

'.Value = .Value

End With



'Copies the data and pastes it two rows down

Sheet1.Range("10:" & lRows).Copy Sheet1.Range(lRows + 3 & ":" & lRows + 3)

Application.ScreenUpdating = True

One thing I noticed and I can't track down is, that it repeats itself. Example, and it works GREAT by the way. Starting with Cell A10 (going across toE10 and down the range) it gives me all the info. But then it skips two rows (which is what I need) but repeats the same data set. (which I don't need) as I said earlier this works exactly like I need, but you are so far over my head in this that I cannot figure out the repeated data.
I am DEFINITELY going to vary this somewhat after I get a full grasp of howyou are doing it and use it several times in this report and future ones....WOW
 
B

Ben McClave

Hans,

The reason it repeats is because of the second to last line (see last threelines copied below).

I wasn't sure what information you wanted to show up when it went two rows down, so as a placeholder, it simply copies what was done above to the row two rows down.

You can change the second-to-last line to the following:

Sheet1.Range(lRows + 3 & ":" & lRows + 3).Select

to select the entire row, or use

Sheet1.Range("A" & lRows + 3).Select

to select the cell from column A two rows down. Using one of those two lines instead of

Sheet1.Range("10:" & lRows).Copy Sheet1.Range(lRows + 3 & ":" & lRows + 3)

will solve the issue with the macro copying the data twice. You can then insert whatever code you need at that point. If this isn't making sense, feel free to send me your file so that I can get a better feel for what you would like to populate on the row two lines down.

Ben
 
H

Hans Hamm

Hans,



The reason it repeats is because of the second to last line (see last three lines copied below).






I wasn't sure what information you wanted to show up when it went two rows down, so as a placeholder, it simply copies what was done above to the row two rows down.



You can change the second-to-last line to the following:



Sheet1.Range(lRows + 3 & ":" & lRows + 3).Select



to select the entire row, or use



Sheet1.Range("A" & lRows + 3).Select



to select the cell from column A two rows down. Using one of those two lines instead of



Sheet1.Range("10:" & lRows).Copy Sheet1.Range(lRows + 3 & ":" & lRows + 3)



will solve the issue with the macro copying the data twice. You can theninsert whatever code you need at that point. If this isn't making sense, feel free to send me your file so that I can get a better feel for what youwould like to populate on the row two lines down.



Ben

Ben when I take the line of code out... it does exactly what I need it to do. The problem is this; once this has run I need some way of telling it to look in Column A find the very last entry and then skip down two rows and start a new section. For Example: This date range may produce 7 different results as below, or it may be 5 or 25. The code you have is doing this perfectly.


COLUMN A B C D E F

Row 10 STORE CallLogs
11 MASM 1 1 0 0 1.0
12 SASM 1 1 0 0 1.0
13 SM 1 1 0 0 1.0
14 ASDS 1 1 0 0 1.0
15 MET 1 1 0 0 1.0
16 OPSMGR 4 4 0 0 1.0
17 MEAS 5 5 0 0 2.2
18 DH 13 13 0 0 1.3

Now I need to tell it to skip down two rows from the last entry in column Aand do something like this
Dim SSection As Range
Set SSection = Sheet1.Range("A20") *** this will be the dynamic range based on the aforementioned different quantity of results (7, 10, 25 or whatever)
With SSection
..Value = ("REASON CODE CallLogs")
End With

Now the plan is to repeat the entire process as you have provided, but based on different criteria... instead of store Calls, it is now looking for Reason Codes. I think I am understanding your code well enough to reproduce.
 
B

Ben McClave

Hans,

I reworked this for you a bit. Rather than continue to layer procedures, Ichanged the sub to take arguments indicating (1) where the data resides inyour workbook, (2) what range contains the information you want to summarize, (3) a string equivalent of this range to use in formulas, and (4) a formula string to make the SUMPRODUCT formula easier to work with.

At the top of the code is a Public variable called lStartRow. This value is initially set to 10 so that data begins to fill on row ten. Then, as themacros run, the lStartRow is adjusted to the next SECTION.

Finally, there is a macro called SummarizeData you can use to run each section. I included two potential sections of data for an example, but you canmodify this routine to match your needs.

To use this, make your changes to the SummarizeData macro and then run it. that macro will call all of the others one at a time. Let me know if thisworks out OK for you.

Ben

Public lStartRow As Long
Sub SummarizeData()
Dim rData As Range 'Location of your data table
Dim sFrm As String 'SUMPRODUCT formula base

Application.ScreenUpdating = False

Sheet1.Rows("10:60000").ClearContents
Set rData = Sheet2.Range("A1:AJ2000")
sFrm = "=SUMPRODUCT((Sheet2!AJ$2:AJ$2000>=Sheet1!C$1)*(Sheet2!AJ$2:AJ$2000<=Sheet1!E$1)"

'First, get Team/Overall Data (takes formula base as only argument)
TeamData sFrm

'Next, get Store data (assumes stores in Sheet2, range H1:H2000)
lStartRow = 10 'Only need to set this once
GetDataDetails rData, Sheet2.Range("H1:H2000"), "Sheet2!H$2:H$2000", sFrm

'Now that Store is done, move to next item of interest (assumes data in Sheet2, range G1:G2000)
GetDataDetails rData, Sheet2.Range("G1:G2000"), "Sheet2!G$2:G$2000", sFrm

'Continue for any other details you need.

Application.ScreenUpdating = True
End Sub

Sub TeamData(sFormula As String)
'GETS OVERALL & TEAM DATA SECTION

With Sheet1.Range("B3")
.Formula = sFormula & ")"
.Value = .Value
End With

With Sheet1.Range("C3")
.Formula = sFormula & "*(Sheet2!G2:G2000=""Closed""))"
.Value = .Value
End With

With Sheet1.Range("D3")
.Formula = sFormula & "*(Sheet2!G2:G2000=""Pending""))"
.Value = .Value
End With

With Sheet1.Range("E3")
.Formula = sFormula & "*(Sheet2!G2:G2000=""Open""))"
.Value = .Value
End With

End Sub

Sub GetDataDetails(rDataRange As Range, rDetailRange As Range, sCompare As String, sForm As String)
'rDataRange is where your data is located
'rDetailRange is the range you wish to summarize (i.e. STORES, REASONS, etc..)
'sCompare is the string representing the range of values to lookup on sheet2 (i.e. Store names, Reason codes, etc.)

Dim wsNew As Worksheet 'New worksheet for data manipulation
Dim rCopy2 As Range 'Blank cell at the top of an unused column
Dim rDateCheck As Range 'Range of dates to check

Dim x As Long 'Used for cycling through the rCopy2 range
Dim y As Long 'Used for cycling through the rPaste range

Dim lastRow As Long 'Last row in column
Dim rPaste As Range 'First cell to receive the data

lastRow = Range(sCompare).Rows.Count + Range(sCompare).Range("A1").Row - 1
Set wsNew = Worksheets.Add
Set rDetailRange = rDetailRange.Resize(lastRow, rDetailRange.Columns.Count)
Set rDateCheck = Sheet2.Range("AJ2:AJ" & Sheet2.Range("AJ50000").End(xlUp).Row)
Set rPaste = Sheet1.Range("A" & lStartRow)

'Prepare criteria for the search
With wsNew
.Range("A1:B1").Value = rDateCheck.Offset(-1).Value
.Range("A2").FormulaR1C1 = "="">="" & Sheet1!R1C3"
.Range("B2").FormulaR1C1 = "=""<="" & Sheet1!R1C5"
.Range("A2:B2").Value = .Range("A2:B2").Value
Set rCopy2 = .Range("G1")
rCopy2.Value = rDetailRange.Value
rDataRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=..Range("A1:B2"), CopyToRange:=rCopy2, Unique:=True
End With

y = 0 'Set to zero to start

'Next, resize the rCopy2 range to match the rDetailRange range size

Set rCopy2 = rCopy2.Resize(wsNew.UsedRange.Rows.Count, 1)


'Now, cycle through each value in rCopy2 starting from the bottom _
and paste it to the final destination.

Dim lRows As Long
lRows = rCopy2.Rows.Count
For x = lRows To 2 Step -1

rPaste.Offset(y, 0).Value = rCopy2.Cells(x, 1)

y = y + 1 'Increment y to ensure next value goes into the cell below
Next x


'Finally, delete the wsNew sheet as it is no longer necessary.
Application.DisplayAlerts = False
wsNew.Delete
Application.DisplayAlerts = True

lRows = lStartRow + lRows - 2
With Sheet1.Range("B" & lStartRow & ":B" & lRows)

..Formula = sForm & "*(" & sCompare & "=Sheet1!A" & lStartRow & "))"
'.Value = .Value
End With

'Store Closed Calls

With Sheet1.Range("C" & lStartRow & ":C" & lRows)

..Formula = sForm & "*(" & sCompare & "=Sheet1!A" & lStartRow & ")*(Sheet2!G$2:G$2000=""Closed""))"
'.Value = .Value
End With

'Store Pending Calls

With Sheet1.Range("D" & lStartRow & ":D" & lRows)

..Formula = sForm & "*(" & sCompare & "=Sheet1!A" & lStartRow & ")*(Sheet2!G$2:G$2000=""Pending""))"
'.Value = .Value
End With

'Store Open Calls

With Sheet1.Range("E" & lStartRow & ":E" & lRows)

..Formula = sForm & "*(" & sCompare & "=Sheet1!A" & lStartRow & ")*(Sheet2!G$2:G$2000=""Open""))"
'.Value = .Value
End With


'Copies the data and pastes it two rows down
lStartRow = lRows + 3

End Sub
 
H

Hans Hamm

Hans,



I reworked this for you a bit. Rather than continue to layer procedures,I changed the sub to take arguments indicating (1) where the data resides in your workbook, (2) what range contains the information you want to summarize, (3) a string equivalent of this range to use in formulas, and (4) a formula string to make the SUMPRODUCT formula easier to work with.



At the top of the code is a Public variable called lStartRow. This valueis initially set to 10 so that data begins to fill on row ten. Then, as the macros run, the lStartRow is adjusted to the next SECTION.



Finally, there is a macro called SummarizeData you can use to run each section. I included two potential sections of data for an example, but you can modify this routine to match your needs.



To use this, make your changes to the SummarizeData macro and then run it.. that macro will call all of the others one at a time. Let me know if this works out OK for you.



Ben



Public lStartRow As Long

Sub SummarizeData()

Dim rData As Range 'Location of your data table

Dim sFrm As String 'SUMPRODUCT formula base



Application.ScreenUpdating = False



Sheet1.Rows("10:60000").ClearContents

Set rData = Sheet2.Range("A1:AJ2000")

sFrm = "=SUMPRODUCT((Sheet2!AJ$2:AJ$2000>=Sheet1!C$1)*(Sheet2!AJ$2:AJ$2000<=Sheet1!E$1)"



'First, get Team/Overall Data (takes formula base as only argument)

TeamData sFrm



'Next, get Store data (assumes stores in Sheet2, range H1:H2000)

lStartRow = 10 'Only need to set this once

GetDataDetails rData, Sheet2.Range("H1:H2000"), "Sheet2!H$2:H$2000", sFrm



'Now that Store is done, move to next item of interest (assumes data in Sheet2, range G1:G2000)

GetDataDetails rData, Sheet2.Range("G1:G2000"), "Sheet2!G$2:G$2000", sFrm



'Continue for any other details you need.



Application.ScreenUpdating = True

End Sub



Sub TeamData(sFormula As String)

'GETS OVERALL & TEAM DATA SECTION



With Sheet1.Range("B3")

.Formula = sFormula & ")"

.Value = .Value

End With



With Sheet1.Range("C3")

.Formula = sFormula & "*(Sheet2!G2:G2000=""Closed""))"

.Value = .Value

End With



With Sheet1.Range("D3")

.Formula = sFormula & "*(Sheet2!G2:G2000=""Pending""))"

.Value = .Value

End With



With Sheet1.Range("E3")

.Formula = sFormula & "*(Sheet2!G2:G2000=""Open""))"

.Value = .Value

End With



End Sub



Sub GetDataDetails(rDataRange As Range, rDetailRange As Range, sCompare As String, sForm As String)

'rDataRange is where your data is located

'rDetailRange is the range you wish to summarize (i.e. STORES, REASONS, etc.)

'sCompare is the string representing the range of values to lookup on sheet2 (i.e. Store names, Reason codes, etc.)



Dim wsNew As Worksheet 'New worksheet for data manipulation

Dim rCopy2 As Range 'Blank cell at the top of an unused column

Dim rDateCheck As Range 'Range of dates to check



Dim x As Long 'Used for cycling through the rCopy2 range

Dim y As Long 'Used for cycling through the rPaste range



Dim lastRow As Long 'Last row in column

Dim rPaste As Range 'First cell to receive the data



lastRow = Range(sCompare).Rows.Count + Range(sCompare).Range("A1").Row - 1

Set wsNew = Worksheets.Add

Set rDetailRange = rDetailRange.Resize(lastRow, rDetailRange.Columns.Count)

Set rDateCheck = Sheet2.Range("AJ2:AJ" & Sheet2.Range("AJ50000").End(xlUp).Row)

Set rPaste = Sheet1.Range("A" & lStartRow)



'Prepare criteria for the search

With wsNew

.Range("A1:B1").Value = rDateCheck.Offset(-1).Value

.Range("A2").FormulaR1C1 = "="">="" & Sheet1!R1C3"

.Range("B2").FormulaR1C1 = "=""<="" & Sheet1!R1C5"

.Range("A2:B2").Value = .Range("A2:B2").Value

Set rCopy2 = .Range("G1")

rCopy2.Value = rDetailRange.Value

rDataRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("A1:B2"), CopyToRange:=rCopy2, Unique:=True

End With



y = 0 'Set to zero to start



'Next, resize the rCopy2 range to match the rDetailRange range size



Set rCopy2 = rCopy2.Resize(wsNew.UsedRange.Rows.Count, 1)





'Now, cycle through each value in rCopy2 starting from the bottom _

and paste it to the final destination.



Dim lRows As Long

lRows = rCopy2.Rows.Count

For x = lRows To 2 Step -1



rPaste.Offset(y, 0).Value = rCopy2.Cells(x, 1)



y = y + 1 'Increment y to ensure next value goes into the cell below

Next x





'Finally, delete the wsNew sheet as it is no longer necessary.

Application.DisplayAlerts = False

wsNew.Delete

Application.DisplayAlerts = True



lRows = lStartRow + lRows - 2

With Sheet1.Range("B" & lStartRow & ":B" & lRows)



.Formula = sForm & "*(" & sCompare & "=Sheet1!A" & lStartRow & "))"

'.Value = .Value

End With



'Store Closed Calls



With Sheet1.Range("C" & lStartRow & ":C" & lRows)



.Formula = sForm & "*(" & sCompare & "=Sheet1!A" & lStartRow & ")*(Sheet2!G$2:G$2000=""Closed""))"

'.Value = .Value

End With



'Store Pending Calls



With Sheet1.Range("D" & lStartRow & ":D" & lRows)



.Formula = sForm & "*(" & sCompare & "=Sheet1!A" & lStartRow & ")*(Sheet2!G$2:G$2000=""Pending""))"

'.Value = .Value

End With



'Store Open Calls



With Sheet1.Range("E" & lStartRow & ":E" & lRows)



.Formula = sForm & "*(" & sCompare & "=Sheet1!A" & lStartRow & ")*(Sheet2!G$2:G$2000=""Open""))"

'.Value = .Value

End With





'Copies the data and pastes it two rows down

lStartRow = lRows + 3



End Sub

It seems to work even though I am almost clueless how you did this... give me a few days to digest and I will probably ask you a couple of questions. I think I am fairly good with formulas, but VBA gives you so much more roomfor manipulation. That is why I have decided to go back and try to learn it. And you have given me a plate full to digest here. Ben I really appreciate your time and effort in working this out for me.
 
H

Hans Hamm

It seems to work even though I am almost clueless how you did this... give me a few days to digest and I will probably ask you a couple of questions.. I think I am fairly good with formulas, but VBA gives you so much more room for manipulation. That is why I have decided to go back and try to learnit. And you have given me a plate full to digest here. Ben I really appreciate your time and effort in working this out for me.

Ben,
Have a better grasp of this now (even though not 100%) but I am having an issue with sorting it. I have tried 3-4 different ways and it always stops with an error.

What I need is in CAPS in the last line(s) of code
'Copies the data and pastes it two rows down
lStartRow = lRows + 4
NEED TO SELECT THE DATA JUST PASTED (currently columns A:L) AND SORT ON COLUMN B HIGH TO LOW

Obviously there is something you have provided which I do not fully follow that is preventing me from doing this as I have recorded macros etc... and just cannot get it to run. The last macro I recorded is the following and Idid try to manually re-write, but I am not following it
ActiveWindow.SmallScroll Down:=3
Range("A12:L26").Select
ActiveWorkbook.Worksheets("Sheet1").SORT.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").SORT.SortFields.Add Key:=Range("B12:B26") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").SORT
.SetRange Range("A12:L26")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
I will say this it is working like a CHARM!

End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top