Option Explicit

Public Sub GetMemoryUsage()
'Based on the original work of Kasper DeJong, reporting memory encoded in Hash Tables
'  Source:  http://www.powerpivotblog.nl/what-is-eating-up-my-memory-powerpivot-excel-edition/
'
'Adjusted to include both Hash and Value encoded memory by Scott Senkeresty
'  Source: http://tinylizard.com/script-update-what-is-eating-up-my-memory-in-power-pivot/
'
'Adjusted to split Hash and Value encoded memory into separate columns by Ken Puls since
' performance issues are typically found from large hash tables first
'
'NOTE:
    Dim wbTarget As Workbook
    Dim ws As Worksheet
    Dim rs As Object
    Dim rs2 As Object
    Dim lRows As Long
    Dim lRow As Long
    Dim sReportName As String
    Dim sQuery As String
    sReportName = "Memory_Usage"

    'Suppress alerts and screen updates
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    'Bind to active workbook
    Set wbTarget = ActiveWorkbook

    'Check if a worksheet already exists
    Err.Clear
    On Error Resume Next
    Set ws = wbTarget.Worksheets(sReportName)
    If Err.Number = 0 Then
        'Worksheet found
        If MsgBox("A memory usage sheet workbook is already detected, " & _
            "do you want to remove the existing one and continue?", vbYesNo) = vbYes Then
                ws.Delete
        Else
            GoTo ExitPoint
        End If
    End If

    On Error GoTo ErrHandler

    'Make sure the model is loaded
    wbTarget.Model.Initialize
    'wbTarget.Model.Refresh

    'Send query to the model
    sQuery = "SELECT dimension_name, attribute_name, DataType,(dictionary_size/1024) AS dictionary_size " & _
        "FROM $system.DISCOVER_STORAGE_TABLE_COLUMNS " & _
        "WHERE dictionary_size > 0"
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open sQuery, wbTarget.Model.DataModelConnection.ModelConnection.ADOConnection
    
    'Send query2 to the model
    sQuery = "SELECT * " & _
        "FROM $system.DISCOVER_STORAGE_TABLE_COLUMN_SEGMENTS " & _
        "WHERE used_size > 0 " & _
        " AND column_id <> 'ID_TO_POS'" & _
        " AND column_id <> 'POS_TO_ID'"
    Set rs2 = CreateObject("ADODB.Recordset")
    rs2.Open sQuery, wbTarget.Model.DataModelConnection.ModelConnection.ADOConnection
    
    lRow = rs.RecordCount + rs2.RecordCount

    If lRow > 0 Then
        'Add report worksheet
        Set ws = wbTarget.Worksheets.Add
        With ws
            .Name = sReportName
            .Range("A1").FormulaR1C1 = "Table"
            .Range("B1").FormulaR1C1 = "Column"
            .Range("C1").FormulaR1C1 = "DataType"
            .Range("D1").FormulaR1C1 = "EncodingType"
            .Range("E1").FormulaR1C1 = "MemorySize (KB)"

            lRows = 2
            rs.MoveFirst

            Do While Not rs.EOF
                'Add the data to the rows
                .Range("A" & lRows).FormulaR1C1 = rs("dimension_name")
                .Range("B" & lRows).FormulaR1C1 = rs("attribute_name")
                .Range("C" & lRows).FormulaR1C1 = rs("DataType")
                .Range("D" & lRows).FormulaR1C1 = "Hash Encoded"
                .Range("E" & lRows).FormulaR1C1 = rs("dictionary_size")
                lRows = lRows + 1
                rs.MoveNext
            Loop

            rs2.MoveFirst
            Do While Not rs2.EOF
                'Add the data to the rows
                .Range("A" & lRows).FormulaR1C1 = rs2("dimension_name")
                .Range("B" & lRows).FormulaR1C1 = rs2("COLUMN_ID")
                .Range("C" & lRows).FormulaR1C1 = ""
                .Range("D" & lRows).FormulaR1C1 = "Value Encoded"
                .Range("E" & lRows).FormulaR1C1 = rs2("USED_SIZE") / 1024#
                lRows = lRows + 1
                rs2.MoveNext
            Loop

            'Format the Memory Size field
            .Columns("D:E").NumberFormat = "#,##0.00"

            'Create table
            .ListObjects.Add(xlSrcRange, .Range("$A$1:$E$" & lRow + 1), , xlYes).Name = "MemorySizeTable"
        End With

        'Create PivotTable
        wbTarget.PivotCaches.Create(SourceType:=xlDatabase, _
            SourceData:="MemorySizeTable", _
            Version:=xlPivotTableVersion15).CreatePivotTable _
            TableDestination:="Memory_Usage!R2C7", _
            TableName:="MemoryTable", _
            DefaultVersion:=xlPivotTableVersion15

        'Modify the PivotTable
        With ws
            With .PivotTables("MemoryTable")
                With .PivotFields("Table")
                    .Orientation = xlRowField
                    .Position = 1
                    .AutoSort xlDescending, "Sum of MemorySize (KB)"
                End With
                With .PivotFields("Column")
                    .Orientation = xlRowField
                    .Position = 2
                    .AutoSort xlDescending, "Sum of MemorySize (KB)"
                End With
                .AddDataField .PivotFields("MemorySize (KB)"), "Sum of MemorySize (KB)", xlSum
                .PivotFields("Table").AutoSort xlDescending, "Sum of MemorySize (KB)"
                .PivotFields("Column").AutoSort xlDescending, "Sum of MemorySize (KB)"
             End With

            'Format the Memory Size field in the PivotTable
            .Columns("H:H").NumberFormat = "#,##0.00"

            'Add conditional formatting
            With .Range("H3")
                .FormatConditions.AddDatabar
                .FormatConditions(.FormatConditions.Count).ShowValue = True
                .FormatConditions(.FormatConditions.Count).SetFirstPriority
                With .FormatConditions(1)
                    .MinPoint.Modify newtype:=xlConditionValueAutomaticMin
                    .MaxPoint.Modify newtype:=xlConditionValueAutomaticMax
                    With .BarColor
                        .Color = 13012579
                        .TintAndShade = 0
                    End With
                    .BarFillType = xlDataBarFillGradient
                    .Direction = xlContext
                    .NegativeBarFormat.ColorType = xlDataBarColor
                    .BarBorder.Type = xlDataBarBorderSolid
                    .NegativeBarFormat.BorderColorType = xlDataBarColor
                    With .BarBorder.Color
                        .Color = 13012579
                        .TintAndShade = 0
                    End With
                    .AxisPosition = xlDataBarAxisAutomatic
                    With .AxisColor
                        .Color = 0
                        .TintAndShade = 0
                    End With
                    With .NegativeBarFormat.Color
                        .Color = 255
                        .TintAndShade = 0
                    End With
                    With .NegativeBarFormat.BorderColor
                        .Color = 255
                        .TintAndShade = 0
                    End With
                    .ScopeType = xlSelectionScope
                    .ScopeType = xlFieldsScope
                End With
            End With

            With .Range("H4")
                .FormatConditions.AddDatabar
                .FormatConditions(.FormatConditions.Count).ShowValue = True
                .FormatConditions(.FormatConditions.Count).SetFirstPriority
                With .FormatConditions(1)
                    .MinPoint.Modify newtype:=xlConditionValueAutomaticMin
                    .MaxPoint.Modify newtype:=xlConditionValueAutomaticMax
                    With .BarColor
                        .Color = 15698432
                        .TintAndShade = 0
                    End With
                    .BarFillType = xlDataBarFillGradient
                    .Direction = xlContext
                    .NegativeBarFormat.ColorType = xlDataBarColor
                    .BarBorder.Type = xlDataBarBorderSolid
                    .NegativeBarFormat.BorderColorType = _
                        xlDataBarColor
                    With .BarBorder.Color
                        .Color = 15698432
                        .TintAndShade = 0
                    End With
                    .AxisPosition = xlDataBarAxisAutomatic
                    With .AxisColor
                        .Color = 0
                        .TintAndShade = 0
                    End With
                    With .NegativeBarFormat.Color
                        .Color = 255
                        .TintAndShade = 0
                    End With
                    With .NegativeBarFormat.BorderColor
                        .Color = 255
                        .TintAndShade = 0
                    End With
                    .ScopeType = xlSelectionScope
                    .ScopeType = xlFieldsScope
                End With
            End With

            'Collapse the PivotTable
            .PivotTables("MemoryTable").PivotFields("Table").ShowDetail = False

            With .PivotTables("MemoryTable").PivotFields("EncodingType")
                .Orientation = xlColumnField
                .Position = 1
            End With

            'Set selection to top
            .Range("MemorySizeTable[[#Headers],[Table]]").Select
        End With
    Else
        MsgBox "No model available", vbOKOnly
    End If
    rs.Close

ExitPoint:
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    Set rs = Nothing
    Exit Sub

ErrHandler:
    MsgBox "An error occured - " & Err.Description, vbOKOnly
    Resume ExitPoint
End Sub