FREQUENCY REPORT

[p45cal]

Attached is an xlsx Excel 2010 file with both macros. Some important amendments to both macros to cope with zeroes (even negative numbers now) and getting the pivot table source data correct.
Pivot table version:

Sub blah1()
Dim xxx As Range
Set DataSht = ActiveSheet
 
On Error Resume Next
Set xxx = Application.InputBox("Select the cell you want to process", "Location of souce data", Default:="$H$3:$H$2063", Type:=8)
On Error GoTo 0
If xxx Is Nothing Then
  MsgBox "Aborted"
  Exit Sub
End If
 
Set TempSht = Sheets.Add(After:=Sheets(Sheets.Count))
DataSht.Activate
TempSht.Visible = 0  'comment-out this line if you want to see what goes on while stepping through the code.
 
TempSht.Range("A2").Resize(xxx.Rows.Count).Value = xxx.Value
Set xxx = TempSht.Columns(1).SpecialCells(xlCellTypeConstants, 23)
vals = xxx.Value
vmax = Application.Max(vals)
vmin = Application.Min(vals)
n = vmin - 1
bin = Evaluate("row(A1:A" & vmax - n & ")+" & n)
Set BinRange = TempSht.Range("B2").Resize(UBound(bin))
BinRange.Value = bin
freqs = Application.WorksheetFunction.Frequency(vals, bin)
BinRange.Offset(, 1).Value = freqs
TempSht.Range("B1:C1").Value = Array("bin", "freq")
Set PT = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=TempSht.Name & "!R1C2:R" & UBound(bin) + 1 & "C3", Version:=xlPivotTableVersion14).CreatePivotTable(TableDestination:=TempSht.Name & "!R1C6", TableName:="PivotTable1", DefaultVersion:=xlPivotTableVersion14)
With PT
  .AddDataField PT.PivotFields("bin"), "Sum of bin", xlSum
  .ColumnGrand = False
  .RowGrand = False
  With .PivotFields("bin")
    .Orientation = xlRowField
    .Position = 1
  End With
  With .PivotFields("freq")
    .Orientation = xlColumnField
    .Position = 1
  End With
  Set PTRngToCopy = Union(.ColumnFields(1).DataRange, .DataBodyRange)
  Set PTRangeDest = PTRngToCopy.Offset(PTRngToCopy.Rows.Count + 9)
  PTRangeDest.Value = PTRngToCopy.Value
End With
 
PTRangeDest.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
Results = PTRangeDest.CurrentRegion.Value
Dim Destn As Range
On Error Resume Next
Set Destn = Application.InputBox("Select the cell where do you want the results", "Location of result table", Type:=8)
On Error GoTo 0
If Destn Is Nothing Then
  MsgBox "Aborted"
Else
  Destn.Resize(UBound(Results), UBound(Results, 2)).Value = Results
  Destn.Resize(1, UBound(Results, 2)).Font.Bold = True
  Application.Goto Destn
End If
Application.DisplayAlerts = False
TempSht.Delete
Application.DisplayAlerts = True
End Sub

and the one which uses in-memory arrays:

Sub blah2()
Dim freqs(), xxx As Range
 
'Set xxx = Columns("I:I").SpecialCells(xlCellTypeConstants, 23)'they're formulae!
'Set xxx = Columns("H:H").SpecialCells(xlCellTypeFormulas, 1) ' there are zeroes!
'Set xxx = Range("H3:H2063") 'works for the data on this particular sheet.
'next 8 lines allow user to select which cells to process:
 
On Error Resume Next
Set xxx = Application.InputBox("Select the cell you want to process", "Location of souce data", Default:="$H$3:$H$2063", Type:=8)
On Error GoTo 0
If xxx Is Nothing Then
  MsgBox "Aborted"
  Exit Sub
End If
 
vals = xxx.Value
vmax = Application.Max(vals)
vmin = Application.Min(vals)
n = vmin - 1
bin = Evaluate("row(A1:A" & vmax - n & ")+" & n)
freqs = Application.WorksheetFunction.Frequency(vals, bin)
ReDim Preserve freqs(1 To UBound(freqs), 1 To 2)
For i = 1 To UBound(bin)
  freqs(i, 2) = bin(i, 1)
Next i
For i = 2 To UBound(bin)
  For j = UBound(bin) To i Step -1
    If freqs(j, 1) < freqs(j - 1, 1) Then
      temp1 = freqs(j, 1): temp2 = freqs(j, 2)
      freqs(j, 1) = freqs(j - 1, 1): freqs(j, 2) = freqs(j - 1, 2)
      freqs(j - 1, 1) = temp1: freqs(j - 1, 2) = temp2
    End If
  Next j
Next i
'determine size of array:
i = 1
ColCount = 0
Do
  myMax = 1
  ColCount = ColCount + 1
  Do
    i = i + 1
    myMax = myMax + 1
  Loop Until freqs(i, 1) <> freqs(i - 1, 1)
  If myMax > Max Then Max = myMax
Loop Until i >= UBound(bin)
Dim Results()
ReDim Results(1 To Max, 1 To ColCount + 1)
i = 1: c = 1
Do
  r = 1
  Results(r, c) = freqs(i, 1)
  r = r + 1
  Do
    Results(r, c) = freqs(i, 2)
    r = r + 1
    i = i + 1
  Loop Until freqs(i, 1) <> freqs(i - 1, 1)
  c = c + 1
Loop Until i > UBound(bin)
Dim Destn As Range
On Error Resume Next
Set Destn = Application.InputBox("Select the cell where do you want the results", "Location of result table", Type:=8)
On Error GoTo 0
If Destn Is Nothing Then
  MsgBox "Aborted"
Else
  Destn.Resize(UBound(Results), UBound(Results, 2)).Value = Results
  Destn.Resize(1, UBound(Results, 2)).Font.Bold = True
  Application.Goto Destn
End If
End Sub

 

[vicktor schausberger]

wonderfull, I already click "like"; thank you, great.
I am not to familiar with the rules, so, it is possible to ask something about the same file we work here, or, I have to open a new thread?.
THANKS P45CAL....

 

[p45cal]

I think it depends on how closely your next query is related to the original query, rather than whether the problem is in the same file or not. So if you had a query about conditional formatting on this same file it would probably go into a new thread. A query on frequency calculations would probably stay here. If you're not sure, start a new thread, but include a link to this thread.

 

[vicktor schausberger]

thanks.