Calculating Min,Max,Quartile in dynamic ranges

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

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)

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.

Quote:

---

Originally Posted by sijpie

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)

---

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.

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!

Quote:

---

Originally Posted by sijpie

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.

---

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

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

Quote:

---

Originally Posted by sijpie

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

---

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.

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..:(



[Code Else ' get value at intersection of column and row
vOut(1, 2) = Intersect(rInp, wsIn.Rows(rFnd.Row)).Value[/Code]

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:

Code:

---

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

---

Quote:

---

Originally Posted by sijpie

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.

---

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

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:

Code:

---

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

Code:

---

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

---

and replace it with

Code:

---

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

---

You now are saying look in all cells

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:

Quote:

---

Originally Posted by sijpie

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

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:

Code:

---

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

Code:

---

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

---

and replace it with

Code:

---

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

---

You now are saying look in all cells

---

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:

Quote:

---

Originally Posted by sijpie

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.

---

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.

Thanks very much for your reply sijpie. Yep sure whenever you have time for it. Meanwhile I'll keep working on it.:cloud9:

Quote:

---

Originally Posted by sijpie

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.

---

Code:

---

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

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:

Quote:

---

Originally Posted by sijpie

Code:

---

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

---

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:

Quote:

---

Originally Posted by sijpie

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.

---

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.

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

Quote:

---

Originally Posted by sijpie

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.

---

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

Code:

---

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

---

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.

Hi,
I need to find Quartiles 1, 2 and 3. Please give me function code for my data set given below.

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