Sub Report()
Dim c As Range
Dim usr As Long
Application.ScreenUpdating = False 'Turn off screen updating while this cleans up workbook'
CreateReport.setsheet 'Pivot worksheet becomes active sheet'
CreateReport.DelSheets 'Removes all irrelevant sheets'
On Error Resume Next 'Allows macro to run if user inputs a number that causes error'
usr = Application.InputBox("Minimum $ Amount to Generate Report", "Input Box", Type:=1) 'Input Box'
If Not IsNumeric(usr) Then Exit Sub 'Validates input'
If Val(usr) < 1 Then Exit Sub
If Range("b2").Value >= usr Then 'Ensures data meets minimum criteria before generating report'
For Each c In Range("b2:B1000") 'Loops through range of data'
CreateReport.setsheet 'Activates Pivot worksheet for each iteration'
If c.Value < usr Then 'Exits loop when data no longer meets minimum criteria'
Exit For
End If
c.Select
CreateReport.showdetail 'Creates worksheet with details of selected range in pivot table'
Next c
CreateReport.CopyFromWorksheets 'Generates our report summary'
CreateReport.Cleanup 'Removes all worksheet that were generated when showdetail was used'
End If
Application.ScreenUpdating = True
End Sub
Sub showdetail()
Selection.showdetail = True 'Will show detail of selection in pivot table.'
End Sub
Sub setsheet()
Dim sht As Worksheet 'Object for handling worksheets in loop
Set sht = ActiveWorkbook.Worksheets("Pivot") 'Working in active workbook
sht.Activate
End Sub
Sub CopyFromWorksheets() 'this sub was found online
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Report Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
Set wrk = ActiveWorkbook 'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "Report" Then
MsgBox "There is a worksheet named 'Report'." & vbCrLf & _
"Please remove or rename this worksheet since 'Report' will be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
trg.Name = "Report" 'Rename the new worksheet
Set sht = wrk.Worksheets(1) 'Get column headers from the first worksheet
colCount = sht.Cells(1, 255).End(xlToLeft).Column 'Column count first
With trg.Cells(1, 1).Resize(1, colCount) 'Now retrieve headers, no copy&paste needed
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
.Font.Bold = True 'Set font as bold
End With
For Each sht In wrk.Worksheets 'We can start loop
If sht.Index = wrk.Worksheets.Count - 3 Then 'If worksheet in loop is the last one, stop execution (it is Report worksheet)
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Report worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
trg.Columns.AutoFit 'Fit the columns in Report worksheet
End Sub
Sub DelSheets()
Dim ws As Worksheet 'Creates worksheet variable'
Application.DisplayAlerts = False 'Disable displaying alerts'
For Each ws In Worksheets 'Deletes all worksheets except the ones containing the report data
If ws.Name <> "Pivot" And ws.Name <> "Table" And ws.Name <> "Source" Then
ws.Delete
End If
Next
Application.DisplayAlerts = True 'Enables displaying alerts
End Sub
Sub Cleanup() 'After the report is generated this deletes all the worksheets that were created
'when the show detail was being used
Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name <> "Pivot" And ws.Name <> "Table" And ws.Name <> "Source" And ws.Name <> "Report" Then
ws.Delete
End If
Next
Application.DisplayAlerts = True
End Sub
[code]
[/SIZE]
