PDA

View Full Version : [SOLVED] Calculating Min,Max,Quartile in dynamic ranges



Beatrix
09-24-2013, 08:47 AM
Hi Everyone ,

I need to calculate Quartile 1-2-3, Min/Max values and value for Z in a specific column. There are multiple workbooks and worksheets. That specific column might be different in each worksheet so I need to ask user to select the range which will be used to do the calculations then process would create a summary tab to list the values for each worksheet like a,b,c,d etc.. as shown below.

Workbooks come from different data sources every quarter so I need to use a vba script which would do the calculation in active worksheet for the range selected by user. Would you be able to help me on this?:help I attached a sample file.





Z
Min
Q1
Q2
Q3
Max


a
48.5
44.7
55.6
61.05
64.725
90.9


b
74.5
61.4
78
81.4
83.1
100


c
24.5
21.9
34.0
39.45
44.9
87.9


d
48
32.5
48.9
53.8
59.7
96.4

sijpie
09-26-2013, 12:17 AM
Which part of the sheets is to be calculated / generated by the macro? The yellow block? And the user is to indicate the column? Is the macro allowed to put the block in a consistent place (like at least on the same row)? Do you need these yellow blocks at all or can the values be generated on the fly and only the summary table generated?

How many sheets will there be? Do you want to have the macro ask for the column for each sheet or could the user just enter the column letter in a cell (say A1) or mark the column with an 'X' in the first row of the column? (personally I would think the last two options would be preferable over having to select, click OK, select, click OK, etc)

Beatrix
09-26-2013, 03:48 AM
Thanks very much for your reply sijpie..

I don't need that yellow parts. I only need a summary table. The thing is there will be many workbooks and each workbook might have different number of worksheets. Macro should calculate Minimum,Maximum and 3 quartiles for defined range. Also there is a specific region I call it Z in this case. I need macro to pull the value for Z from defined range and paste into summary table. The other thing is how users would specify the range in the process..As you said marking first and last row of the column might be the preferable option. In that case, if there are some blank rows in that range macro wouldn't get the blank row as the last row of the range would it?

I really appreciate for your help.





Which part of the sheets is to be calculated / generated by the macro? The yellow block? And the user is to indicate the column? Is the macro allowed to put the block in a consistent place (like at least on the same row)? Do you need these yellow blocks at all or can the values be generated on the fly and only the summary table generated?

How many sheets will there be? Do you want to have the macro ask for the column for each sheet or could the user just enter the column letter in a cell (say A1) or mark the column with an 'X' in the first row of the column? (personally I would think the last two options would be preferable over having to select, click OK, select, click OK, etc)

sijpie
09-26-2013, 07:16 AM
The user only would need to give the column. Finding the last entry in a column is very easy. But you have to decide if the user does that on his/her own or if the macro has to guide it (which means more clicks). What is your preference? I can also do it that the macro will flag up and ask the user for those sheets which he hasn't marked the column. But then I need to know if the user is entering the column letter in a fixed cell (say A1, or B1 depending on headers), or if he is marking with an X in a fixed row (this needs to be a free row, depending on headers).

Let's start with making the process work for one workbook, with a number of sheets with not necessarily the same layout.

Beatrix
09-26-2013, 08:27 AM
hmmm..If the row needs to be free then I was thinking he could insert a row at the top and put an X say in D1. However There might be some other figures in that column which shouldn't be included to the calculation. Lets say the range start D12:D163 and d9 and d10 have got some figures which shouldn't be included so he needs to select D12:D163. Is that possible to guide the user asking like "Please highlight the range in each worksheet to calculate the figures"? If there are 5 worksheets then he would select that specific range in each worksheets then macro would create the summary tab? Is it possible like that or I'm making it too complicated? :think:

many thanks!


The user only would need to give the column. Finding the last entry in a column is very easy. But you have to decide if the user does that on his/her own or if the macro has to guide it (which means more clicks). What is your preference? I can also do it that the macro will flag up and ask the user for those sheets which he hasn't marked the column. But then I need to know if the user is entering the column letter in a fixed cell (say A1, or B1 depending on headers), or if he is marking with an X in a fixed row (this needs to be a free row, depending on headers).

Let's start with making the process work for one workbook, with a number of sheets with not necessarily the same layout.

sijpie
09-26-2013, 09:11 AM
No, that is easily doable.
On what criterium is the choice of column made? Can that be automated at all?

Beatrix
09-26-2013, 09:49 AM
Unfortunately user needs to decide which column should be included to the process as all workbooks come from different sources and they all have got a different data structure:(:( I am afraid that part can't be automated at all; but still good. I mean to be able to guide the user to highlight the ranges and run the data into the summary tab.That's perfect. If I learn how to do this I'll keep practicing on this. I know basics in VBA as had the online training and need to have more trainings..hopefully get there one day:whip




No, that is easily doable.
On what criterium is the choice of column made? Can that be automated at all?

sijpie
09-27-2013, 04:33 AM
Option Explicit




'------------------------------------------------
Sub CreateSummary()
'
' Macro to create summary table containing the _
Min, Max, and 3 Quartiles of 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
Dim wsIn As Worksheet, wsSum As Worksheet
Dim lR 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 7)
vOut(1, 2) = "Z"
vOut(1, 3) = "Min"
vOut(1, 4) = "Q1"
vOut(1, 5) = "Q2"
vOut(1, 6) = "Q3"
vOut(1, 7) = "Max"
rOut.Resize(1, 7).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
Set rInp = Application.InputBox( _
prompt:="Please select 1st cell of range in this sheet " _
& vbCrLf & "to be processed for Quartiles." & vbCrLf _
& " You can use your mouse to select", _
Title:="Select Quartiles Range", _
Type:=8)
If rInp Is Nothing Then GoTo GetRange ' loop if invalid input
If rInp.Columns.Count > 1 Or rInp.Parent.Name <> wsIn.Name _
Then GoTo GetRange ' loop if multiple columns selected or on wrong sheet

' extend range to end of sheet
lR = wsIn.Cells(Rows.Count, rInp.Column).End(xlUp).Row ' last row, now skip summary
lR = wsIn.Cells(lR, rInp.Column).End(xlUp).Row '
Set rInp = rInp.Cells(1, 1).Resize(lR - rInp.Row + 1, 1)
' calculate quartiles from provided range
With Application.WorksheetFunction
vOut(1, 1) = wsIn.Name
vOut(1, 3) = .Min(rInp)
vOut(1, 4) = .Quartile(rInp, 1)
vOut(1, 5) = .Quartile(rInp, 2)
vOut(1, 6) = .Quartile(rInp, 3)
vOut(1, 7) = .Max(rInp)
End With
'find the 'Z'
Set rSrch = wsIn.Columns(iCCC)
Set rFnd = rSrch.Find(what:=sZZZ, after:=Cells(rInp.Row - 1, 3), _
lookat:=xlWhole, LookIn:=xlValues, _
searchdirection:=xlNext)
If rFnd Is Nothing Then ' not found
vOut(1, 2) = vbNullString
Else ' get value at intersection of column and row
vOut(1, 2) = Intersect(rInp, wsIn.Rows(rFnd.Row)).Value
End If
rOut.Resize(1, 7).Value = vOut 'print values to sheet
Set rOut = rOut.Offset(1, 0) ' set to next row

End If
Next wsIn

'format table
Set rOut = rOut.Offset(-1, 0).CurrentRegion
FormatSumTbl rOut

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 .Rows(1)
.Font.Underline = xlUnderlineStyleSingle
End With
With .Columns(2)
.Font.Bold = True
.Font.Underline = xlNone
End With
With Cells(1, 2).Font
.Color = -16776961
.TintAndShade = 0
End With
End With
End Sub


This should do the trick on a single workbook. Try it on an example workbook) like the one you posted)
Read the comments to see what and how it works, and what you need to modify ( like the two constants possibly) for your real workbooks.

The user only needs to select the first cell of the column to be processed. The cells above it are ignored, as is the summary row at the bottom.

Beatrix
09-30-2013, 06:16 AM
Hi sijpie

Many many thanks for the code!! That's brilliant! Thanks very much for your time..I really appreciate it:bow::bow:

Please see feedback here:

I tried it on the spreadsheet I posted. Code does all calculations and creates the summary tab when I select the 1st cell of the range in each worksheet. It allows me to select whole range as well like from AA6 to AA157 :yes 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..:(






I tested it in another workbook too. In this case I replaced Z with the actual word however It's in column A instead of column C so it couldn't find the figures for "Z" and left it blank. I was wondering is it possible to search it in whole worksheet instead of column C? Is it difficult?:think:


Const iCCC As Integer = 3 'Column C where sZZZ is to be searched






[code]
Option Explicit




'------------------------------------------------
Sub CreateSummary()
'
' Macro to create summary table containing the _
Min, Max, and 3 Quartiles of 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
Dim wsIn As Worksheet, wsSum As Worksheet
Dim lR 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 7)
vOut(1, 2) = "Z"
vOut(1, 3) = "Min"
vOut(1, 4) = "Q1"
vOut(1, 5) = "Q2"
vOut(1, 6) = "Q3"
vOut(1, 7) = "Max"
rOut.Resize(1, 7).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
Set rInp = Application.InputBox( _
prompt:="Please select 1st cell of range in this sheet " _
& vbCrLf & "to be processed for Quartiles." & vbCrLf _
& " You can use your mouse to select", _
Title:="Select Quartiles Range", _
Type:=8)
If rInp Is Nothing Then GoTo GetRange ' loop if invalid input
If rInp.Columns.Count > 1 Or rInp.Parent.Name <> wsIn.Name _
Then GoTo GetRange ' loop if multiple columns selected or on wrong sheet

' extend range to end of sheet
lR = wsIn.Cells(Rows.Count, rInp.Column).End(xlUp).Row ' last row, now skip summary
lR = wsIn.Cells(lR, rInp.Column).End(xlUp).Row '
Set rInp = rInp.Cells(1, 1).Resize(lR - rInp.Row + 1, 1)
' calculate quartiles from provided range
With Application.WorksheetFunction
vOut(1, 1) = wsIn.Name
vOut(1, 3) = .Min(rInp)
vOut(1, 4) = .Quartile(rInp, 1)
vOut(1, 5) = .Quartile(rInp, 2)
vOut(1, 6) = .Quartile(rInp, 3)
vOut(1, 7) = .Max(rInp)
End With
'find the 'Z'
Set rSrch = wsIn.Columns(iCCC)
Set rFnd = rSrch.Find(what:=sZZZ, after:=Cells(rInp.Row - 1, 3), _
lookat:=xlWhole, LookIn:=xlValues, _
searchdirection:=xlNext)
If rFnd Is Nothing Then ' not found
vOut(1, 2) = vbNullString
Else ' get value at intersection of column and row
vOut(1, 2) = Intersect(rInp, wsIn.Rows(rFnd.Row)).Value
End If
rOut.Resize(1, 7).Value = vOut 'print values to sheet
Set rOut = rOut.Offset(1, 0) ' set to next row

End If
Next wsIn

'format table
Set rOut = rOut.Offset(-1, 0).CurrentRegion
FormatSumTbl rOut

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 .Rows(1)
.Font.Underline = xlUnderlineStyleSingle
End With
With .Columns(2)
.Font.Bold = True
.Font.Underline = xlNone
End With
With Cells(1, 2).Font
.Color = -16776961
.TintAndShade = 0
End With
End With
End Sub


This should do the trick on a single workbook. Try it on an example workbook) like the one you posted)
Read the comments to see what and how it works, and what you need to modify ( like the two constants possibly) for your real workbooks.

The user only needs to select the first cell of the column to be processed. The cells above it are ignored, as is the summary row at the bottom.

sijpie
09-30-2013, 10:10 AM
If your sheets sometimes do not have the summary row, then amend it as follows. Find this part in the code:


' extend range to end of sheet
lR = wsIn.Cells(Rows.Count, rInp.Column).End(xlUp).Row ' last row, now skip summary
lR = wsIn.Cells(lR, rInp.Column).End(xlUp).Row '

replace these three lines with:


' extend range to end of sheet
lR = wsIn.Cells(Rows.Count, rInp.Column).End(xlUp).Row ' last row, now skip summary if exists
If wsIn.Cells(lR, rInp.Column).offset(-1,0) = vbNullstring then ' there is a summary line,
lR = wsIn.Cells(lR, rInp.Column).End(xlUp).Row 'exclude it
End If

That is where after finding the last row it checks if it is a summary line (on its own) if so it goes up more to exclude the summary line.


OK, now about finding the 'Z' anywhere on the sheet: Find this code:


'find the 'Z'
Set rSrch = wsIn.Columns(iCCC)

and replace it with


'find the 'Z'
Set rSrch = wsIn.Cells



You now are saying look in all cells

Beatrix
10-02-2013, 05:18 AM
Thank you! Thank you! Thank you! :bow::bow::bow:

Sorry for the late response..It takes time for me to understand and test it. Just changing one word Columns to Cells does the job..Coding is like a magic!:thumb


PS: There are some blank rows between the range and total row so it's not included to the calculation but if I delete total row, it doesn't give an error any more..

brilliant!Many many thanks again..:cloud9:





If your sheets sometimes do not have the summary row, then amend it as follows. Find this part in the code:


' extend range to end of sheet
lR = wsIn.Cells(Rows.Count, rInp.Column).End(xlUp).Row ' last row, now skip summary
lR = wsIn.Cells(lR, rInp.Column).End(xlUp).Row '

replace these three lines with:


' extend range to end of sheet
lR = wsIn.Cells(Rows.Count, rInp.Column).End(xlUp).Row ' last row, now skip summary if exists
If wsIn.Cells(lR, rInp.Column).offset(-1,0) = vbNullstring then ' there is a summary line,
lR = wsIn.Cells(lR, rInp.Column).End(xlUp).Row 'exclude it
End If

That is where after finding the last row it checks if it is a summary line (on its own) if so it goes up more to exclude the summary line.


OK, now about finding the 'Z' anywhere on the sheet: Find this code:


'find the 'Z'
Set rSrch = wsIn.Columns(iCCC)

and replace it with


'find the 'Z'
Set rSrch = wsIn.Cells



You now are saying look in all cells

Beatrix
12-12-2013, 08:36 AM
Hi sijpie ,

I was wondering if you could help me about modifying this script you wrote before?: pray2:: pray2:

Currently this script gives user the option to select a range in each worksheet when the range is selected then it moves to the next worksheet. Is it possible to add a warning message before moving to the next tab? The thing is some worksheets require multiple calculations based on more than one range. Can we add yes no message box saying "would you like to move to the next worksheet?" If no was clicked then it would ask to select another range in the same worksheet if yes was clicked then it would move to the next tab??:think: I don't know if there is another way to be able to select multiple ranges for the calculations in a single worksheet.:doh:




Option Explicit




'------------------------------------------------
Sub CreateSummary()
'
' Macro to create summary table containing the _
Min, Max, and 3 Quartiles of 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
Dim wsIn As Worksheet, wsSum As Worksheet
Dim lR 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 7)
vOut(1, 2) = "Z"
vOut(1, 3) = "Min"
vOut(1, 4) = "Q1"
vOut(1, 5) = "Q2"
vOut(1, 6) = "Q3"
vOut(1, 7) = "Max"
rOut.Resize(1, 7).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
Set rInp = Application.InputBox( _
prompt:="Please select 1st cell of range in this sheet " _
& vbCrLf & "to be processed for Quartiles." & vbCrLf _
& " You can use your mouse to select", _
Title:="Select Quartiles Range", _
Type:=8)
If rInp Is Nothing Then GoTo GetRange ' loop if invalid input
If rInp.Columns.Count > 1 Or rInp.Parent.Name <> wsIn.Name _
Then GoTo GetRange ' loop if multiple columns selected or on wrong sheet

' extend range to end of sheet
lR = wsIn.Cells(Rows.Count, rInp.Column).End(xlUp).Row ' last row, now skip summary
lR = wsIn.Cells(lR, rInp.Column).End(xlUp).Row '
Set rInp = rInp.Cells(1, 1).Resize(lR - rInp.Row + 1, 1)
' calculate quartiles from provided range
With Application.WorksheetFunction
vOut(1, 1) = wsIn.Name
vOut(1, 3) = .Min(rInp)
vOut(1, 4) = .Quartile(rInp, 1)
vOut(1, 5) = .Quartile(rInp, 2)
vOut(1, 6) = .Quartile(rInp, 3)
vOut(1, 7) = .Max(rInp)
End With
'find the 'Z'
Set rSrch = wsIn.Columns(iCCC)
Set rFnd = rSrch.Find(what:=sZZZ, after:=Cells(rInp.Row - 1, 3), _
lookat:=xlWhole, LookIn:=xlValues, _
searchdirection:=xlNext)
If rFnd Is Nothing Then ' not found
vOut(1, 2) = vbNullString
Else ' get value at intersection of column and row
vOut(1, 2) = Intersect(rInp, wsIn.Rows(rFnd.Row)).Value
End If
rOut.Resize(1, 7).Value = vOut 'print values to sheet
Set rOut = rOut.Offset(1, 0) ' set to next row

End If
Next wsIn

'format table
Set rOut = rOut.Offset(-1, 0).CurrentRegion
FormatSumTbl rOut

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 .Rows(1)
.Font.Underline = xlUnderlineStyleSingle
End With
With .Columns(2)
.Font.Bold = True
.Font.Underline = xlNone
End With
With Cells(1, 2).Font
.Color = -16776961
.TintAndShade = 0
End With
End With
End Sub


This should do the trick on a single workbook. Try it on an example workbook) like the one you posted)
Read the comments to see what and how it works, and what you need to modify ( like the two constants possibly) for your real workbooks.

The user only needs to select the first cell of the column to be processed. The cells above it are ignored, as is the summary row at the bottom.

sijpie
12-13-2013, 07:27 AM
This should be possible, but I do not have time to look at it at the moment. Maybe later in the week or after Xmas.

Beatrix
12-15-2013, 06:27 AM
Thanks very much for your reply sijpie. Yep sure whenever you have time for it. Meanwhile I'll keep working on it.:cloud9:



This should be possible, but I do not have time to look at it at the moment. Maybe later in the week or after Xmas.

sijpie
01-01-2014, 05:43 AM
'------------------------------------------------
Sub CreateSummary()
'
' Macro to create summary table containing the _
Min, Max, And 3 Quartiles of 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
Dim wsIn As Worksheet, wsSum As Worksheet
Dim lR 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 7)
vOut(1, 2) = "Z"
vOut(1, 3) = "Min"
vOut(1, 4) = "Q1"
vOut(1, 5) = "Q2"
vOut(1, 6) = "Q3"
vOut(1, 7) = "Max"
rOut.Resize(1, 7).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 range in this sheet " _
& vbCrLf & "to be processed for Quartiles (to use the whole column)" & vbCrLf _
& "Or select the ranges individually using mouse and Ctrl key." & vbCrLf _
& "You can use your mouse 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 multiple columns selected or on wrong sheet

If rInp.Cells.Count = 1 Then
' extend range to end of sheet
lR = wsIn.Cells(Rows.Count, rInp.Column).End(xlUp).Row ' last row, now skip summary if exists
If wsIn.Cells(lR, rInp.Column).Offset(-1, 0) = vbNullString Then ' there is a summary line,
lR = wsIn.Cells(lR, rInp.Column).End(xlUp).Row 'exclude it
End If
Set rInp = rInp.Cells(1, 1).Resize(lR - rInp.Row + 1, 1)
End If
' calculate quartiles from provided range
With Application.WorksheetFunction
vOut(1, 1) = wsIn.Name
vOut(1, 3) = .Min(rInp)
vOut(1, 4) = .Quartile(rInp, 1)
vOut(1, 5) = .Quartile(rInp, 2)
vOut(1, 6) = .Quartile(rInp, 3)
vOut(1, 7) = .Max(rInp)
End With
'find the 'Z'
Set rSrch = wsIn.Cells
Set rFnd = rSrch.Find(what:=sZZZ, after:=Cells(rInp.Row - 1, 3), _
lookat:=xlWhole, LookIn:=xlValues, _
searchdirection:=xlNext)
If rFnd Is Nothing Then ' not found
vOut(1, 2) = vbNullString
Else ' get value at intersection of column and row
vOut(1, 2) = Intersect(rInp, wsIn.Rows(rFnd.Row)).Value
End If
rOut.Resize(1, 7).Value = vOut 'print values to sheet
Set rOut = rOut.Offset(1, 0) ' set to next row

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 .Rows(1)
.Font.Underline = xlUnderlineStyleSingle
End With
With .Columns(2)
.Font.Bold = True
.Font.Underline = xlNone
End With
With Cells(1, 2).Font
.Color = -16776961
.TintAndShade = 0
End With
End With
End Sub



try this. It allows the user to select non contiguous ranges . If (s)he selects one cell then the column is used if selecting sepearate ranges (using the mouse & ctrl key) then those ranges are used. So cells T5:T89, W90:W95, T96:T107 can be selected (all at the same time).

It still automatically goes to the next sheet. Will that be sufficient?

Beatrix
01-20-2014, 06:11 AM
Hi sijpie

I just got the notification yesterday for your reply. However the date shows 01/01/2014. So sorry for the late response if you replied this thread on 01/01. Normally I check my threads when I get the notification to my personal email. I'll test the script and will get back to you asap. Hope you had a great Christmas and New Year. Also thanks very much for not forgetting about the thread and helping me on this. :cloud9:




'------------------------------------------------
Sub CreateSummary()
'
' Macro to create summary table containing the _
Min, Max, And 3 Quartiles of 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
Dim wsIn As Worksheet, wsSum As Worksheet
Dim lR 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 7)
vOut(1, 2) = "Z"
vOut(1, 3) = "Min"
vOut(1, 4) = "Q1"
vOut(1, 5) = "Q2"
vOut(1, 6) = "Q3"
vOut(1, 7) = "Max"
rOut.Resize(1, 7).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 range in this sheet " _
& vbCrLf & "to be processed for Quartiles (to use the whole column)" & vbCrLf _
& "Or select the ranges individually using mouse and Ctrl key." & vbCrLf _
& "You can use your mouse 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 multiple columns selected or on wrong sheet

If rInp.Cells.Count = 1 Then
' extend range to end of sheet
lR = wsIn.Cells(Rows.Count, rInp.Column).End(xlUp).Row ' last row, now skip summary if exists
If wsIn.Cells(lR, rInp.Column).Offset(-1, 0) = vbNullString Then ' there is a summary line,
lR = wsIn.Cells(lR, rInp.Column).End(xlUp).Row 'exclude it
End If
Set rInp = rInp.Cells(1, 1).Resize(lR - rInp.Row + 1, 1)
End If
' calculate quartiles from provided range
With Application.WorksheetFunction
vOut(1, 1) = wsIn.Name
vOut(1, 3) = .Min(rInp)
vOut(1, 4) = .Quartile(rInp, 1)
vOut(1, 5) = .Quartile(rInp, 2)
vOut(1, 6) = .Quartile(rInp, 3)
vOut(1, 7) = .Max(rInp)
End With
'find the 'Z'
Set rSrch = wsIn.Cells
Set rFnd = rSrch.Find(what:=sZZZ, after:=Cells(rInp.Row - 1, 3), _
lookat:=xlWhole, LookIn:=xlValues, _
searchdirection:=xlNext)
If rFnd Is Nothing Then ' not found
vOut(1, 2) = vbNullString
Else ' get value at intersection of column and row
vOut(1, 2) = Intersect(rInp, wsIn.Rows(rFnd.Row)).Value
End If
rOut.Resize(1, 7).Value = vOut 'print values to sheet
Set rOut = rOut.Offset(1, 0) ' set to next row

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 .Rows(1)
.Font.Underline = xlUnderlineStyleSingle
End With
With .Columns(2)
.Font.Bold = True
.Font.Underline = xlNone
End With
With Cells(1, 2).Font
.Color = -16776961
.TintAndShade = 0
End With
End With
End Sub



try this. It allows the user to select non contiguous ranges . If (s)he selects one cell then the column is used if selecting sepearate ranges (using the mouse & ctrl key) then those ranges are used. So cells T5:T89, W90:W95, T96:T107 can be selected (all at the same time).

It still automatically goes to the next sheet. Will that be sufficient?

Beatrix
01-21-2014, 09:44 AM
Many many thanksss sijpie!!

I've just run the script. That's perfect:thumbhowever summary table results with one calculation for each worksheet. If there are multiple selections then it should result with separate calculations. Say there are 2 different ranges in a worksheet then summary table should list that worksheet twice with 2 different calculations. Is that possible? :think:: pray2:





Option Explicit




'------------------------------------------------
Sub CreateSummary()
'
' Macro to create summary table containing the _
Min, Max, and 3 Quartiles of 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
Dim wsIn As Worksheet, wsSum As Worksheet
Dim lR 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 7)
vOut(1, 2) = "Z"
vOut(1, 3) = "Min"
vOut(1, 4) = "Q1"
vOut(1, 5) = "Q2"
vOut(1, 6) = "Q3"
vOut(1, 7) = "Max"
rOut.Resize(1, 7).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
Set rInp = Application.InputBox( _
prompt:="Please select 1st cell of range in this sheet " _
& vbCrLf & "to be processed for Quartiles." & vbCrLf _
& " You can use your mouse to select", _
Title:="Select Quartiles Range", _
Type:=8)
If rInp Is Nothing Then GoTo GetRange ' loop if invalid input
If rInp.Columns.Count > 1 Or rInp.Parent.Name <> wsIn.Name _
Then GoTo GetRange ' loop if multiple columns selected or on wrong sheet

' extend range to end of sheet
lR = wsIn.Cells(Rows.Count, rInp.Column).End(xlUp).Row ' last row, now skip summary
lR = wsIn.Cells(lR, rInp.Column).End(xlUp).Row '
Set rInp = rInp.Cells(1, 1).Resize(lR - rInp.Row + 1, 1)
' calculate quartiles from provided range
With Application.WorksheetFunction
vOut(1, 1) = wsIn.Name
vOut(1, 3) = .Min(rInp)
vOut(1, 4) = .Quartile(rInp, 1)
vOut(1, 5) = .Quartile(rInp, 2)
vOut(1, 6) = .Quartile(rInp, 3)
vOut(1, 7) = .Max(rInp)
End With
'find the 'Z'
Set rSrch = wsIn.Columns(iCCC)
Set rFnd = rSrch.Find(what:=sZZZ, after:=Cells(rInp.Row - 1, 3), _
lookat:=xlWhole, LookIn:=xlValues, _
searchdirection:=xlNext)
If rFnd Is Nothing Then ' not found
vOut(1, 2) = vbNullString
Else ' get value at intersection of column and row
vOut(1, 2) = Intersect(rInp, wsIn.Rows(rFnd.Row)).Value
End If
rOut.Resize(1, 7).Value = vOut 'print values to sheet
Set rOut = rOut.Offset(1, 0) ' set to next row

End If
Next wsIn

'format table
Set rOut = rOut.Offset(-1, 0).CurrentRegion
FormatSumTbl rOut

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 .Rows(1)
.Font.Underline = xlUnderlineStyleSingle
End With
With .Columns(2)
.Font.Bold = True
.Font.Underline = xlNone
End With
With Cells(1, 2).Font
.Color = -16776961
.TintAndShade = 0
End With
End With
End Sub


This should do the trick on a single workbook. Try it on an example workbook) like the one you posted)
Read the comments to see what and how it works, and what you need to modify ( like the two constants possibly) for your real workbooks.

The user only needs to select the first cell of the column to be processed. The cells above it are ignored, as is the summary row at the bottom.

sijpie
01-21-2014, 10:59 PM
Anything you can do manually is possible. But I can only look at it next week. Can you show a summary table how it would be with two ranges selected? Please colour the selected ranges so I can see how it sticks together.

Beatrix
01-29-2014, 12:38 PM
Hi sijpie ,

It's amazing to be able to do everything with VBA instead of doing manually!:cloud9:

I coloured the selected ranges in each tab and showed them in summary table as you said. Please see attachment called vbax sample quartile5.

I appreciate your help very much. Many many thanks.:bow: I promise I'll go through each single line to be able to understand the script:yes


Anything you can do manually is possible. But I can only look at it next week. Can you show a summary table how it would be with two ranges selected? Please colour the selected ranges so I can see how it sticks together.

sijpie
02-11-2014, 05:37 AM
OK, sorry for the delay, suddenly remembered it was still outstanding. The code has't changed much. I now check the input range to see if it has more than one area (non-contiguous range), and for each area it checks if the are more columns and runs the formulas for each column. For ease of checking in the output table the columns used are mentioned (rather than jsut Range1, Range2). The formatting sub has changed for the extra column



'------------------------------------------------
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

Beatrix
02-13-2014, 03:57 AM
Thanks very much for your reply sijpie..This script is doing a perfect job! You helped me to save much time for the others..
I appreciate for all your help :bow:

Cheers
B.

fiza ahmad
05-12-2018, 11:05 AM
Hi,
I need to find Quartiles 1, 2 and 3. Please give me function code for my data set given below.

Paul_Hossler
05-12-2018, 12:18 PM
1. No data set

2. This is a very old thread - You would be better off starting a new one by using the [+Post New Thread] button on the top left of the main screen