Macro to create a Pivot Table with Dynamic Range and Dynamic Fields

[DistinctX]

Hi Everyone,

This is my first post! I'm hoping someone can help me with this doozy (well at least for me it is ).

My data file has fields that resemble this: Q1_1, Q1_2, Q1_3 or QX_n, QX_1+1 QX_1+2, ... QX_1+y
- Where X can be any number, n and y is the last increment.
- The values in each of these fields is either 0 or 1 (but never Null or blank)
- The number of rows always varies
- There are three rows of column headers but only the 3rd column header row has the Q values (the only important column header)

I'm trying to create a Pivot table using a macro where the first row of values will have the Sum of QX_1 and then the second row of values has a calculated field with the formula "Sum(QX_1)/the number of rows excluding the column headers" as a percentage with no decimal points.
Also the first Row Label Will be rename to add a # and the second row label will have a % (see table below). This is considered as one "pair".

I have to do this for however many fields and then I have to sort the "pairs" in descending order according to the percentages.

The Pivot Table should look something like this:

Q1	Total
Q1_1 #	51
Q1_1 %	72%
Q1_2 #	42
Q1_2 %	59%
Q1_3 #	31
Q1_3 %	44%

<tbody>
</tbody>

I would actually prefer it this way but I don't know how that's possible:

Q1	#	%
Q1_1	51	72%
Q1_2	42	59%
Q1_3	31	44%

<tbody>
</tbody>

Your help would be greatly appreciated! I started the vba script and figured out the dynamic range but I'm stuck with going to the next pair. I'm thinking some kind of loop but I'm just learning vba...

Sub TESTER()

'Message Box Input

Dim yVal As Long

    On Error Resume Next
        Application.DisplayAlerts = False
            yVal = Application.InputBox _
             (Prompt:="How many options are there?", _
                    Title:="INPUT BOX", Type:=1)
    
    On Error GoTo 0

    Application.DisplayAlerts = True
    
    If yVal < 1 Then MsgBox "Please Enter a Value Greater than 0"
    If yVal < 1 Then Exit Sub

'rename sheet to Data and Create a new Sheet for the Pivot Table
ActiveSheet.Name = "Data"
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Pivot"
    Sheets("Data").Select
    Range("A3").Select
    
'Setup for the Pivot Table
    
    Dim pt As PivotTable
    Dim strField As String
    Dim WSD As Worksheet
    Set WSD = Worksheets("Data")
    Dim PTOutput As Worksheet
    Set PTOutput = Worksheets("Pivot")
    Dim PTCache As PivotCache
    Dim PRange As Range
 
    ' Find the last row with data
    Dim finalRow As Long
    finalRow = ActiveSheet.Cells(Application.Rows.Count, 1).End(xlUp).Row
    
    
    LR = Range("A" & Rows.Count).End(xlUp).Row
     
    ' Find the last column with data
    Dim finalCol As Long
    finalCol = WSD.Cells(3, Application.Columns.Count).End(xlToLeft).Column
     
    ' Find the range of the data
    Set PRange = WSD.Cells(3, 1).Resize(finalRow, finalCol)
    Set PTCache = ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=PRange)
 
    ' Create the pivot table
    Set pt = PTCache.CreatePivotTable(TableDestination:=PTOutput.Cells(3, 1), _
    TableName:="Report")
     
    
    ' Set update to manual to avoid recomputation while laying out
    pt.ManualUpdate = True
    
    ' Define the layout of the pivot table
    Sheets("Pivot").Select
     
    ActiveSheet.PivotTables("Report").AddDataField ActiveSheet.PivotTables( _
        "Report").PivotFields("Q1_1"), "Sum of Q1_1", xlSum
    
    ActiveSheet.PivotTables("Report").CalculatedFields.Add "Q1A", _
        "=SUM(Q1_1/CountA(Q1_1))", True
    ActiveSheet.PivotTables("Report").PivotFields("Q2A").Orientation = _
        xlDataField
    With ActiveSheet.PivotTables("Report").DataPivotField
        .Orientation = xlRowField
        .Position = 1
    End With
    
    With ActiveSheet.PivotTables("Report").PivotFields("Sum of Q1A")
        .NumberFormat = "0%"
    End With
     
  ' Now calc the pivot table
    pt.ManualUpdate = False
     
End Sub

Thank you for the help!

 

[DistinctX]

Sorry, please ignore the n value in my post. It's suppose to say "QX_1+1, QX_1+2, QX_1+3, ... QX_1+y" only. Thanks!