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 & "
" & 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
