VBA code. Pivot table drilldown on a new windows form

[hcova]

Hi There.
If you double click on a pivot table cell, a new sheet automatically opens and displays the database list. Then you need to delete it manually and go back to your pivot table.
What I really would like to do is create an Excel VBA Code so when you double click in the cell, the database list will be displayed in a new floating window instead of the default new sheet.
This new floating window should keep open until the user decides to close it.
The user needs to keep open many floating windows at the same time, according to the number of cells the user has double-clicked on the pivot table.
Let me show this with images:
1) This is the current pivot table

2) Then the user makes a double click in B15 Cell and a pop-up appears displaying the database.
Next, the user makes a double click in another cell (C17) and a new pop-up appears in the database instead of a new sheet.
A design detail: The double-clicked cells change their background colors as well as the pop-up window borders.

Any code, help, or link will be welcomed
Best Regards
Hernán

 

[EXCEL MAX]

Hello Hcova,
here is one quick created code.
It's not ideal but you can use it as basic template.
Code have dangerous lines to create and remove folder and files, so be careful when testing it. Test it with debuger line by line.
Every time you click on the pivot table code create new folder in the "E:\"PivotTable\" location
and ".xlsx" file (from pivot table data sheet) .
Imideatly after that opens this new file as pop up Excel window in the specific location.
When main workbook is closed temporary folder "E:\"PivotTable\" will be delated.
Window border color will not be changed, but sheet tab changing color.
All this code goes to the "ThisWorkbook" module...

Option Explicit

Dim vSWBDC As Boolean
Dim vT As Long, vL As Long
Dim vRed As Integer, vGreen As Integer, vBlue As Integer
Dim vWB As Workbook
Dim vWBCaption As String

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    
    On Error Resume Next
    Kill "E:\PivotTables\*.*"    ' delete all files in the folder
    RmDir "E:\PivotTables\"      ' delete folder
    On Error GoTo 0
    
End Sub

Private Sub Workbook_Open()

    On Error Resume Next
    MkDir "E:\PivotTables"       'create temporary folder
    
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    
    If vSWBDC = True Then
        Application.ScreenUpdating = False
        ActiveWindow.WindowState = xlNormal
        ActiveWindow.Top = 0
        ActiveWindow.Left = 0
        ActiveWindow.Width = 1000
        ActiveWindow.Height = 700
        vWBCaption = ActiveWindow.Caption
        Sh.Copy
        ActiveWorkbook.ActiveSheet.Tab.Color = RGB(vRed, vGreen, vBlue)
        With ActiveWorkbook
            .SaveAs Filename:="E:\PivotTables\" & Sh.Name, _
                  FileFormat:=xlOpenXMLWorkbook
            .Close False
        End With
        vSWBDC = False
        Workbooks.Open "E:\PivotTables\" & Sh.Name
        
        Application.DisplayAlerts = False
        Sh.Delete
        vT = 0
        vL = 500
        For Each vWB In Workbooks
            With Workbooks(vWB.Name)
                If Not vWB.Name = vWBCaption Then
                    .Activate
                    .Windows(vWB.Name).Height = 300
                    .Windows(vWB.Name).Width = 300
                     vL = vL + 20
                     vT = vT + 30
                    .Windows(vWB.Name).Left = vL
                    .Windows(vWB.Name).Top = vT
                End If
            End With
        Next vWB
        Application.ScreenUpdating = True
    End If
    
End Sub

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    
    If Sh.Name = "PivotTable" And Not Target = "" Then
        vRed = Int(255 * Rnd)
        vGreen = Int(255 * Rnd)
        vBlue = Int(255 * Rnd)
        Target.Interior.Color = RGB(vRed, vGreen, vBlue)
        vSWBDC = True
    End If

End Sub

 

[hcova]

Hello Hcova,
here is one quick created code.
It's not ideal but you can use it as basic template.
Code have dangerous lines to create and remove folder and files, so be careful when testing it. Test it with debuger line by line.
Every time you click on the pivot table code create new folder in the "E:\"PivotTable\" location
and ".xlsx" file (from pivot table data sheet) .
Imideatly after that opens this new file as pop up Excel window in the specific location.
When main workbook is closed temporary folder "E:\"PivotTable\" will be delated.
Window border color will not be changed, but sheet tab changing color.
All this code goes to the "ThisWorkbook" module...

Option Explicit

Dim vSWBDC As Boolean
Dim vT As Long, vL As Long
Dim vRed As Integer, vGreen As Integer, vBlue As Integer
Dim vWB As Workbook
Dim vWBCaption As String

Private Sub Workbook_BeforeClose(Cancel As Boolean)
   
    On Error Resume Next
    Kill "E:\PivotTables\*.*"    ' delete all files in the folder
    RmDir "E:\PivotTables\"      ' delete folder
    On Error GoTo 0
   
End Sub

Private Sub Workbook_Open()

    On Error Resume Next
    MkDir "E:\PivotTables"       'create temporary folder
   
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
   
    If vSWBDC = True Then
        Application.ScreenUpdating = False
        ActiveWindow.WindowState = xlNormal
        ActiveWindow.Top = 0
        ActiveWindow.Left = 0
        ActiveWindow.Width = 1000
        ActiveWindow.Height = 700
        vWBCaption = ActiveWindow.Caption
        Sh.Copy
        ActiveWorkbook.ActiveSheet.Tab.Color = RGB(vRed, vGreen, vBlue)
        With ActiveWorkbook
            .SaveAs Filename:="E:\PivotTables\" & Sh.Name, _
                  FileFormat:=xlOpenXMLWorkbook
            .Close False
        End With
        vSWBDC = False
        Workbooks.Open "E:\PivotTables\" & Sh.Name
       
        Application.DisplayAlerts = False
        Sh.Delete
        vT = 0
        vL = 500
        For Each vWB In Workbooks
            With Workbooks(vWB.Name)
                If Not vWB.Name = vWBCaption Then
                    .Activate
                    .Windows(vWB.Name).Height = 300
                    .Windows(vWB.Name).Width = 300
                     vL = vL + 20
                     vT = vT + 30
                    .Windows(vWB.Name).Left = vL
                    .Windows(vWB.Name).Top = vT
                End If
            End With
        Next vWB
        Application.ScreenUpdating = True
    End If
   
End Sub

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
   
    If Sh.Name = "PivotTable" And Not Target = "" Then
        vRed = Int(255 * Rnd)
        vGreen = Int(255 * Rnd)
        vBlue = Int(255 * Rnd)
        Target.Interior.Color = RGB(vRed, vGreen, vBlue)
        vSWBDC = True
    End If

End Sub

Hi EXCEL MAX.
Thanks a lot for your time and code.
However I do not why but this code doesn´t work when I have opened more that this worksheet.
If I have another worksheet i get the error shown below.
Could you please give a hand to solve it?

Second, could please help me with the following:
In the code you share me each time I double click in a PT cell I get a new window with the database related with the selected cell.
If I click again in another PT cell I will get again a new window with the data related to this new cell.
Conlusion: for each double click a new windows appears as it is shwon below

However Now I would like to select 2 cells from the pivot table (for instance pressing ctrl and click them to select, or simply a shortcut) and then when I release the ctrl key, a new pop window appears including the databases details related with the previous 2 selectd PT cells. And of course all included in a new worksheet.

It your code can select more than 2 PT cells i will be happy.

Best reagards
Hernan

 

[EXCEL MAX]

Hello again Hcova,
I'm sorry because you not found my first code as useable.
This what you trying to do seems easier.
First create macro and shortcut (Ctrl+q) for example.
In the VBA editor find this shortcut code and put this line there.

Sub Macro1()

    Application.OnTime Now + TimeValue("00:00:01"), "ActivateNewView"

End Sub

In the same module insert this code...

Sub ActivateNewView()

    Dim vWS As Worksheet, vWS1 As Worksheet, _
    vExist As Boolean, vA, vNR As Integer, vN As Integer
    
    Application.ScreenUpdating = False
    Set vWS = ActiveSheet
    vA = Split(Selection.Address, ",")
    For Each vWS1 In ActiveWorkbook.Worksheets
        If vWS1.Name = "NewView" Then
            vExist = True
            vWS1.UsedRange.ClearContents
        End If
    Next vWS1
    If Not vExist = True Then
        Sheets.Add
        ActiveSheet.Name = "NewView"
    End If
    vNR = 1
    vWS.Activate
    For vN = 0 To UBound(vA)
        Range(vA(vN)).Select
        Application.DoubleClick
        ActiveSheet.UsedRange.Copy Sheets("NewView").Cells(vNR, 1)
        vNR = vNR + ActiveSheet.UsedRange.Rows.Count
        Application.DisplayAlerts = False
        ActiveSheet.Delete
    Next
    Sheets("NewView").Activate
    
End Sub

Select PT sheet, press Ctrl and select few cells in the PT.
Now press Ctrl+q shortcut and ...Wait a second...
I hope this is what you looking for.

 

[hcova]

Hello again Hcova,
I'm sorry because you not found my first code as useable.
This what you trying to do seems easier.
First create macro and shortcut (Ctrl+q) for example.
In the VBA editor find this shortcut code and put this line there.

Sub Macro1()

    Application.OnTime Now + TimeValue("00:00:01"), "ActivateNewView"

End Sub

In the same module insert this code...

Sub ActivateNewView()

    Dim vWS As Worksheet, vWS1 As Worksheet, _
    vExist As Boolean, vA, vNR As Integer, vN As Integer
   
    Application.ScreenUpdating = False
    Set vWS = ActiveSheet
    vA = Split(Selection.Address, ",")
    For Each vWS1 In ActiveWorkbook.Worksheets
        If vWS1.Name = "NewView" Then
            vExist = True
            vWS1.UsedRange.ClearContents
        End If
    Next vWS1
    If Not vExist = True Then
        Sheets.Add
        ActiveSheet.Name = "NewView"
    End If
    vNR = 1
    vWS.Activate
    For vN = 0 To UBound(vA)
        Range(vA(vN)).Select
        Application.DoubleClick
        ActiveSheet.UsedRange.Copy Sheets("NewView").Cells(vNR, 1)
        vNR = vNR + ActiveSheet.UsedRange.Rows.Count
        Application.DisplayAlerts = False
        ActiveSheet.Delete
    Next
    Sheets("NewView").Activate
   
End Sub

Select PT sheet, press Ctrl and select few cells in the PT.
Now press Ctrl+q shortcut and ...Wait a second...
I hope this is what you looking for.

Dear EXCEL MAX.
Thanks a lot for your great code.
Your first code help me a lot as the second one.

Please let me explain what I need in 3 steps only.

1) Suppose you have a simple and common PT

2) In this PT sheet, I press Ctrl and select a few cells, in the below case, 3 cells. Note that each time I select these cells I need that the VBA code change their background color (in a random way)

3) Then I press Ctrl+Q (the shortcut) and a new excel pop-up window opens,....not in a new sheet. This new worksheet contains the drill down of each selected cell.

Dear EXCEL MAX this is that I need.
I would appreciate your generous help again.
Have a good night.
Regards
Hernan

 

[EXCEL MAX]

I'm glad if this was helpful.

 

[EXCEL MAX]

As first, sorry because I didn't initially saw upper part of your post. I was hungover.
As a second, I'm not shure will this code works with newer versions of Excel.
If everything works as version 2016, basicly you can expect result as you wanted, but be careful from unexpected errors.
Create shortcut for Macro1.
This goes to "ThisWorkbook" code module.

Dim vRed As Integer, vGreen As Integer, vBlue As Integer

Private Sub Workbook_Open()
       
    Call CtrlTest
   
End Sub


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    
    Call CtrlTest
    vPTName = Sh.Name
    If Ctrl = True Then
        If Not ActiveCell = "" Then
            vA = Split(Selection.Address, ",")
            For vN = 0 To UBound(vA)
                vRed = Int(255 * Rnd)
                vGreen = Int(255 * Rnd)
                vBlue = Int(255 * Rnd)
                Sh.Range(vA(vN)).Interior.Color = _
                    RGB(vRed, vGreen, vBlue)
            Next vN
        End If
    Else
        On Error Resume Next
        For vN = 0 To UBound(vA)
            Sh.Range(vA(vN)).Interior.Color = xlNone
        Next vN
        If Selection.Count = 1 Then
            vA(0) = Selection.Address
            Sh.Range(vA(0)).Interior.Color = _
                    RGB(vRed, vGreen, vBlue)
        End If
    End If

End Sub

And this to the Standard code module.

Dim vTableName As String
Dim vN As Integer, vNR2 As Long, vNR As Long, vNC As Integer
Public vA, Ctrl, vPTName As String
Public vNewExcel As Excel.Application
Public Declare Function GetKeyState Lib "user32" _
    (ByVal nVirtKey As Long) As Integer
Const VK_CONTROL As Integer = &H11

Sub CtrlTest()

    If GetKeyState(VK_CONTROL) < 0 Then Ctrl = True Else Ctrl = False
   
End Sub

Sub Macro1()
   
    vNR2 = 1
    Application.OnTime Now + TimeValue("00:00:01"), "ActivateNewView"

End Sub

Sub ActivateNewView()
   
    Application.ScreenUpdating = False
    On Error GoTo EX
    Set vNewExcel = New Excel.Application
    With vNewExcel
        .Workbooks.Add
        .Caption = "NEW VIEW"
        .ActiveWindow.Caption = vPTName
        .ActiveWindow.ActiveSheet.Name = vPTName
    End With
    For vN = 0 To UBound(vA)
        Range(vA(vN)).Select
        Application.DoubleClick
        vNR = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).row
        vNC = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
        vTableName = "NewViewTable" & ActiveSheet.Name
        With vNewExcel.ActiveWorkbook.ActiveSheet
            .ListObjects.Add(xlSrcRange, .Range(.Cells(vNR2, 1), _
            .Cells(vNR2 + vNR - 1, vNC)), , xlYes).Name = vTableName
        End With
        ActiveSheet.Range("A1", Cells(vNR, vNC)).Copy
        vNewExcel.ActiveWorkbook.ActiveSheet. _
            Range("A" & vNR2).PasteSpecial xlPasteValues
        vNR2 = vNR2 + vNR
        Application.DisplayAlerts = False
        ActiveSheet.Delete
    Next vN
    For vN = 1 To UBound(vA)
        ActiveSheet.Range(vA(vN)).Interior.Color = xlNone
    Next vN
    vNewExcel.Visible = True
    Exit Sub
EX:

End Sub

Press Ctrl and select few values from PT. All selected values changing color.
Press Ctrl + shortcut to run Macro 1 , and new window will apear.

 

[hcova]

Hi again EXCEL MAX.
For Excel 64-bits you can replace in your code:

Public Declare Function GetKeyState Lib "user32" _
(ByVal nVirtKey As Long) As Integer

for

Declare PtrSafe Function GetKeyState Lib "USER32" (ByVal nVirtKey As Long) As Integer

It will work!.

Second, each time when the macro code finishes, if II select any cell with the mouse, the cell changes its backgroud color. How can I turn off this "bug"?
Could you give a hand to solve this?

Best regards
Hernan

 

[EXCEL MAX]

I was try to give you some guideline, but I see you know much more about VBA,
so I guess it won't be a hard to understand changes.
Here's improved code...

'to the ThisWorkbook module
Dim vRed As Integer, vGreen As Integer, vBlue As Integer

Private Sub Workbook_Open()
        
    Call CtrlTest
    
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    
    Call CtrlTest
    Select Case Sh.Name
        Case "PT", "PT2", "PT3"
            On Error Resume Next
            For vN = 0 To UBound(vA)
                Sh.Range(vA(vN)).Interior.Color = xlNone
            Next vN
            vPTName = Sh.Name
            If Ctrl = True Then
                If Not ActiveCell = "" Then
                    vA = Split(Selection.Address, ",")
                    For vN = 0 To UBound(vA)
                        vRed = Int(255 * Rnd)
                        vGreen = Int(255 * Rnd)
                        vBlue = Int(255 * Rnd)
                        Sh.Range(vA(vN)).Interior.Color = _
                            RGB(vRed, vGreen, vBlue)
                    Next vN
                End If
            End If
            If ActiveCell = "" Then
                ActiveCell.Interior.Color = xlNone
                For i = 0 To UBound(vA)
                    Range(vA(i)).Interior.Color = xlNone
                Next i
            End If
    End Select
    
End Sub

'to the Standard module
Dim vTableName As String
Dim vN As Integer, vNR2 As Long, vNR As Long, vNC As Integer
Public vA, Ctrl, vPTName As String
Public vNewExcel As Excel.Application
Declare PtrSafe Function GetKeyState Lib "USER32" _
    (ByVal nVirtKey As Long) As Integer
Const VK_CONTROL As Integer = &H11

Sub CtrlTest()

    If GetKeyState(VK_CONTROL) = -128 Or _
       GetKeyState(VK_CONTROL) = -127 Or _
       GetKeyState(VK_CONTROL) = 0 Or _
       GetKeyState(VK_CONTROL) = 1 Then
       Ctrl = True
    Else
       Ctrl = False
    End If
    
End Sub

Sub Macro1()
    
    vNR2 = 1
    Application.OnTime Now + TimeValue("00:00:01"), "ActivateNewView"

End Sub

Sub ActivateNewView()
    
    Application.ScreenUpdating = False
    Set vNewExcel = New Excel.Application
    With vNewExcel
        .Workbooks.Add
        .Caption = "NEW VIEW"
        .ActiveWindow.Caption = vPTName
        .ActiveWindow.ActiveSheet.Name = vPTName
    End With
    For vN = 0 To UBound(vA)
        Range(vA(0)).Select
        Application.DoubleClick
        vNR = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).row
        vNC = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
        vTableName = "NewViewTable" & ActiveSheet.Name
        With vNewExcel.ActiveWorkbook.ActiveSheet
            .ListObjects.Add(xlSrcRange, .Range(.Cells(vNR2, 1), _
            .Cells(vNR2 + vNR - 1, vNC)), , xlYes).Name = vTableName
        End With
        Application.DisplayAlerts = False
        ActiveSheet.Range("A1", Cells(vNR, vNC)).Copy
        vNewExcel.ActiveWorkbook.ActiveSheet. _
            Range("A" & vNR2).PasteSpecial xlPasteValues
        vNR2 = vNR2 + vNR
        Application.DisplayAlerts = False
        ActiveSheet.Delete
    Next vN
    For vN = 0 To UBound(vA)
        ActiveSheet.Range(vA(vN)).Interior.Color = xlNone
    Next vN
    vNewExcel.Visible = True

End Sub

 

[EXCEL MAX]

Now I saw some lines that are not necessary.

'to the ThisWorkbook module
Dim vRed As Integer, vGreen As Integer, vBlue As Integer

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    
    Select Case Sh.Name
        Case "PT", "PT2", "PT3"
            On Error Resume Next
            For vN = 0 To UBound(vA)
                Sh.Range(vA(vN)).Interior.Color = xlNone
            Next vN
            vPTName = Sh.Name
            If ActiveCell = "" Then
                ActiveCell.Interior.Color = xlNone
                For i = 0 To UBound(vA)
                    Range(vA(i)).Interior.Color = xlNone
                Next i
            Else
                vA = Split(Selection.Address, ",")
                For vN = 0 To UBound(vA)
                    vRed = Int(255 * Rnd)
                    vGreen = Int(255 * Rnd)
                    vBlue = Int(255 * Rnd)
                    Sh.Range(vA(vN)).Interior.Color = _
                        RGB(vRed, vGreen, vBlue)
                Next vN
            End If
    End Select
    
End Sub

'to the Standard module
Dim vTableName As String
Dim vN As Integer, vNR2 As Long, vNR As Long, vNC As Integer
Public vA, vPTName As String
Public vNewExcel As Excel.Application

Sub Macro1()
    
    vNR2 = 1
    Application.OnTime Now + TimeValue("00:00:01"), "ActivateNewView"

End Sub

Sub ActivateNewView()
    
    Application.ScreenUpdating = False
    Set vNewExcel = New Excel.Application
    With vNewExcel
        .Workbooks.Add
        .Caption = "NEW VIEW"
        .ActiveWindow.Caption = vPTName
        .ActiveWindow.ActiveSheet.Name = vPTName
    End With
    For vN = 0 To UBound(vA)
        Range(vA(0)).Select
        Application.DoubleClick
        vNR = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).row
        vNC = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
        vTableName = "NewViewTable" & ActiveSheet.Name
        With vNewExcel.ActiveWorkbook.ActiveSheet
            .ListObjects.Add(xlSrcRange, .Range(.Cells(vNR2, 1), _
            .Cells(vNR2 + vNR - 1, vNC)), , xlYes).Name = vTableName
        End With
        ActiveSheet.Range("A1", Cells(vNR, vNC)).Copy
        vNewExcel.ActiveWorkbook.ActiveSheet. _
            Range("A" & vNR2).PasteSpecial xlPasteValues
        vNR2 = vNR2 + vNR
        Application.DisplayAlerts = False
        ActiveSheet.Delete
    Next vN
    For vN = 0 To UBound(vA)
        ActiveSheet.Range(vA(vN)).Interior.Color = xlNone
    Next vN
    vNewExcel.Visible = True

End Sub