'------------------------------------------------
Sub CreateSummary()
'
' Macro to create summary table containing the _
Min, Max, And 3 Quartiles of selected ranges in _
each sheet in the workbook. The user is requested To _
Input the first cell of the range for the _
calculations. In addition the value of the _
row at 'Z' (in column C) is entered in the _
table.
'------------------------------------------------
Dim rInp As Range, rOut As Range, rFnd As Range, rSrch As Range, rC As Range, rA As Range
Dim wsIn As Worksheet, wsSum As Worksheet
Dim lR As Long, lC As Long, lA As Long
Dim vOut As Variant
Const sZZZ As String = "Z" ' This is the value to indicate special row
Const iCCC As Integer = 3 'Column C where sZZZ is to be searched
' Check if Summary sheet exists, else create
On Error Resume Next 'in case it doesn't exist
Set wsSum = Sheets("Summary")
On Error GoTo 0 ' reset error behaviour
If wsSum Is Nothing Then ' sheet does not exist
Set wsSum = Sheets.Add(after:=Sheets(Sheets.Count))
wsSum.Name = "Summary"
End If
Set rOut = wsSum.Range("D2")
'for our output we will gather the data into an array _
Then print out a row at once For Each sheet. _
first the header:
ReDim vOut(1 To 1, 1 To 8)
vOut(1, 1) = "Sheet"
vOut(1, 2) = "Range"
vOut(1, 3) = "Z"
vOut(1, 4) = "Min"
vOut(1, 5) = "Q1"
vOut(1, 6) = "Q2"
vOut(1, 7) = "Q3"
vOut(1, 8) = "Max"
rOut.Resize(1, UBound(vOut, 2)).Value = vOut 'print headers to sheet
Set rOut = rOut.Offset(1, 0) ' set to next row
' Now go through each sheet, get user to enter _
range For processing. Then calculate quartiles _
And add the Z figure.
For Each wsIn In Sheets
If wsIn.Name <> wsSum.Name Then
GetRange:
wsIn.Activate
On Error GoTo CleanUp
Set rInp = Application.InputBox( _
prompt:="Please select 1st cell of each range in this sheet " _
& vbCrLf & "to be processed for Quartiles (to use the whole column)" & vbCrLf _
& "You can use your mouse and Ctrl key to select.", _
Title:="Select Quartiles Range", _
Type:=8)
On Error GoTo 0
If rInp Is Nothing Then GoTo GetRange ' loop if invalid input
If rInp.Parent.Name <> wsIn.Name Then GoTo GetRange ' loop if selection is on wrong sheet
For lA = 1 To rInp.Areas.Count ' count areas in the input range: non-contiguous areas
Set rA = rInp.Areas(lA)
For lC = 1 To rA.Columns.Count ' check for multiple columns in each contiguous area
Set rC = rA(1, lC) ' use the first cell of each column and extend it vertically
' extend range to end of sheet
lR = wsIn.Cells(Rows.Count, rC.Column).End(xlUp).Row ' last row, now skip summary if exists
If wsIn.Cells(lR, rC.Column).Offset(-1, 0) = vbNullString Then ' there is a summary line,
lR = wsIn.Cells(lR, rC.Column).End(xlUp).Row 'exclude it
End If
Set rC = rC.Cells(1, 1).Resize(lR - rC.Row + 1, 1)
' calculate quartiles from provided range
With Application.WorksheetFunction
vOut(1, 1) = wsIn.Name
vOut(1, 2) = "Column " & Left(rC.Address(1, 0), InStr(1, rC.Address(1, 0), "$") - 1)
vOut(1, 4) = .Min(rC)
vOut(1, 5) = .Quartile(rC, 1)
vOut(1, 6) = .Quartile(rC, 2)
vOut(1, 7) = .Quartile(rC, 3)
vOut(1, 8) = .Max(rC)
End With
'find the 'Z'
Set rSrch = wsIn.Cells
Set rFnd = rSrch.Find(what:=sZZZ, after:=Cells(rC.Row - 1, 3), _
lookat:=xlWhole, LookIn:=xlValues, _
searchdirection:=xlNext)
If rFnd Is Nothing Then ' not found
vOut(1, 3) = vbNullString
Else ' get value at intersection of column and row
vOut(1, 3) = Intersect(rC, wsIn.Rows(rFnd.Row)).Value
End If
rOut.Resize(1, UBound(vOut, 2)).Value = vOut 'print values to sheet
Set rOut = rOut.Offset(1, 0) ' set to next row
Next lC
Next lA
End If
Next wsIn
'format table
Set rOut = rOut.Offset(-1, 0).CurrentRegion
FormatSumTbl rOut
wsSum.Activate
CleanUp:
Set wsIn = Nothing
Set wsSum = Nothing
Set rOut = Nothing
Set rInp = Nothing
Set rFnd = Nothing
Set rSrch = Nothing
End Sub
Sub FormatSumTbl(rTbl As Range)
'
' FormatSumTbl Macro
' Format the Summary Table & headings
'
'
With rTbl
.HorizontalAlignment = xlCenter
.NumberFormat = "0.0"
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Columns(1)
.Borders(xlInsideHorizontal).LineStyle = xlNone
.EntireColumn.AutoFit
With .Font
.Color = -16776961
.TintAndShade = 0
End With
End With
With .Columns(2)
.Borders(xlInsideHorizontal).LineStyle = xlNone
.EntireColumn.AutoFit
With .Font
.Color = -16776961
.TintAndShade = 0
End With
End With
With .Rows(1)
.Font.Underline = xlUnderlineStyleSingle
End With
With .Columns(3)
.Font.Bold = True
.Font.Underline = xlNone
End With
With Cells(1, 2).Font
.Color = -16776961
.TintAndShade = 0
End With
End With
End Sub
I attached a sample file.
Originally Posted by sijpie
163 and d9 and d10 have got some figures which shouldn't be included so he needs to select D12
However I deleted the last row which shows total figures in each tab and it gave Run-time error "91" object variable not set ?? debugging takes to below line..
