VBA: 2 specific problems: 1 - set table row as range and 2 - refine existing code

[Jonstrup]

Hi all

Below is a bit of code. I prompt user to select a cell (although so far its possible to select more than one but I'll fix that) as starting point from which a table will be inserted. Then I prompt for user input to specify the range in a pivot table frequency array formulas calculations should be based on.

It's actually working OK if the user selects the top row, but I would like to skip the user input.


The solution I am really after should set a variable range for the formulas referencing the datarow in the pivot table and also a way to insert the starting point for the new table in the same row as the pivot tableheaders offset by two columns.

My first problem I need help with is setting the first datarow in a pivot table as a range (not knowing the value of either the label or the headers) and also to set the starting point two columns to the right of the pivot table . I have read through countless of post and blogs on how to reference tables but I cant get it to work.

My second problem is that the code below doesn't exactly qualify as tidy. I am using select which is not cool, I repeat my self pointing at each sell to paste values and I have specified the size of the new table as 8 where ideally that would be a variable equal to the highest MAX. I simply haven't been able to make a loop that work. Any ideas as to how?

I would be very happy indeed for any help.

I haven't uploaded an example but would be happy to if needed.

Kind regards
Kasper

Sub TaleToCalculateMaxAndSuccesive()


    Dim rRange As Range
    Dim rSelect As Range
    Dim tRange As Range
    Dim FormulaPart1 As String
    Dim FormulaPart2 As String
    Dim r As Range
    Dim PT As PivotTable


'select the cell from which the table should be pasted

    On Error Resume Next
        Application.DisplayAlerts = False
            Set rRange = Application.InputBox(Prompt:= _
                "Angiv den en celle hvor du vil have frekvenstabllen til at starte med samentælling af serier i", _
                    Title:="BRUG MUSEN TIL AT ANGIVE OMRÅDE", Type:=8)


    On Error GoTo 0
        Application.DisplayAlerts = True
        If rRange Is Nothing Then
           Exit Sub
        Else
End If


'select the data area for the array formula

On Error Resume Next
        Application.DisplayAlerts = False
            Set rSelect = Application.InputBox(Prompt:= _
                "Marker hele den øverste cellerække med data som der skal tælles i ", _
                    Title:="BRUG MUSEN TIL AT ANGIVE OMRÅDE", Type:=8)
    On Error GoTo 0
        Application.DisplayAlerts = True


        If rSelect Is Nothing Then
        MsgBox "Intet område angivet"
           Exit Sub
        Else


  Application.ScreenUpdating = False


'calls another sub that copies the first row of the pivottable

Call CopyRowRange
'---- bekow is the called sub


'Sub CopyRowRange()
'Dim PT As PivotTable


'Set PT = ActiveSheet.PivotTables(1)


'PT.RowRange.Copy
'
'End Sub
'------


'pastes the first column of the pivot table (including header name) in the first specified cell - rRange. In this case it is the names of participants.

rRange.Offset(-1, 0).PasteSpecial Paste:=xlPasteValues
'the pasted values is used to create a table
ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name = "Table name"


'as the data is now a table whenever a value is pasted to an adjacent cell it becomes part of the table
'which is handy beacuese when I pase the array formulas below they autofill all the way down


rRange.Offset(-1, 1).Value = "Længste serie"
rRange.Offset(-1, 2).Value = "Antal serier af 2"
rRange.Offset(-1, 3).Value = "Antal serier af 3"
rRange.Offset(-1, 4).Value = "Antal serier af 4"
rRange.Offset(-1, 5).Value = "Antal serier af 5"
rRange.Offset(-1, 6).Value = "Antal serier af 6"
rRange.Offset(-1, 7).Value = "Antal serier af 7"
rRange.Offset(-1, 8).Value = "Antal serier af 8"
        
'pastes array formula for max frequency - and because it is a talbe it autofills

rRange.Offset(0, 1).FormulaArray = "=MAX(FREQUENCY(IF(" + rSelect.Address(False, False) + "=1,COLUMN(" + rSelect.Address(False, False) + ")),IF(" + rSelect.Address(False, False) + "<>1,COLUMN(" + rSelect.Address(False, False) + "))))"


'pastes array formula for counts of 2 in succesion, for 3 in succesion and so on and so on.

rRange.Offset(0, 2).FormulaArray = "=SUM(IF(FREQUENCY(IF(" + rSelect.Address(False, False) + "=1,COLUMN(" + rSelect.Address(False, False) + ")),IF(1-(" + rSelect.Address(False, False) + "=1),COLUMN(" + rSelect.Address(False, False) + ")))=2,1))"
rRange.Offset(0, 3).FormulaArray = "=SUM(IF(FREQUENCY(IF(" + rSelect.Address(False, False) + "=1,COLUMN(" + rSelect.Address(False, False) + ")),IF(1-(" + rSelect.Address(False, False) + "=1),COLUMN(" + rSelect.Address(False, False) + ")))=3,1))"
rRange.Offset(0, 4).FormulaArray = "=SUM(IF(FREQUENCY(IF(" + rSelect.Address(False, False) + "=1,COLUMN(" + rSelect.Address(False, False) + ")),IF(1-(" + rSelect.Address(False, False) + "=1),COLUMN(" + rSelect.Address(False, False) + ")))=4,1))"
rRange.Offset(0, 5).FormulaArray = "=SUM(IF(FREQUENCY(IF(" + rSelect.Address(False, False) + "=1,COLUMN(" + rSelect.Address(False, False) + ")),IF(1-(" + rSelect.Address(False, False) + "=1),COLUMN(" + rSelect.Address(False, False) + ")))=5,1))"
rRange.Offset(0, 6).FormulaArray = "=SUM(IF(FREQUENCY(IF(" + rSelect.Address(False, False) + "=1,COLUMN(" + rSelect.Address(False, False) + ")),IF(1-(" + rSelect.Address(False, False) + "=1),COLUMN(" + rSelect.Address(False, False) + ")))=6,1))"
rRange.Offset(0, 7).FormulaArray = "=SUM(IF(FREQUENCY(IF(" + rSelect.Address(False, False) + "=1,COLUMN(" + rSelect.Address(False, False) + ")),IF(1-(" + rSelect.Address(False, False) + "=1),COLUMN(" + rSelect.Address(False, False) + ")))=7,1))"
rRange.Offset(0, 8).FormulaArray = "=SUM(IF(FREQUENCY(IF(" + rSelect.Address(False, False) + "=1,COLUMN(" + rSelect.Address(False, False) + ")),IF(1-(" + rSelect.Address(False, False) + "=1),COLUMN(" + rSelect.Address(False, False) + ")))=7,1))"


End If
        
    rRange.Offset(-1, 0).Columns.AutoFit
        
        Application.ScreenUpdating = True
   
End Sub