Sub Macro1_UpdateAndCopy() Application.DisplayAlerts = False Dim pt As PivotTable Set pt = Sheets("Sheet1").PivotTables("PivotTable1") pt.RefreshTable Sheets("Sheet1").Select 'Create sheet for results or delete existing and create Dim sh As Worksheet, flg As Boolean For Each sh In Worksheets If sh.Name Like "Matrix" Then flg = True: Exit For Next If flg = True Then Sheets("Matrix").Select ActiveWindow.SelectedSheets.Delete Sheets.Add.Name = "Matrix" Else Sheets.Add.Name = "Matrix" End If 'Copy Pivot Sheets("Sheet1").Select Dim LastRow As Long With ActiveSheet LastRow = .Range("A1").SpecialCells(xlCellTypeLastCell).Row End With Dim LastColumn As Long With ActiveSheet LastColumn = .Range("A1").SpecialCells(xlCellTypeLastCell).Column End With Range(Cells(1, 1), Cells(LastRow, LastColumn)).Select Selection.Copy Sheets("Matrix").Select Cells(1, 1).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.DisplayAlerts = True Call Macro2_InsertText End Sub Sub Macro2_InsertText() Dim LastRow As Long With ActiveSheet LastRow = .Range("B1").SpecialCells(xlCellTypeLastCell).Row End With Dim LastColumn As Long With ActiveSheet LastColumn = .Range("A1").SpecialCells(xlCellTypeLastCell).Column End With Range(Columns(1), Columns(LastColumn)).Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Dim a For irow = 4 To LastRow a = Cells(irow, 2).Value For icol = 3 To LastColumn If (Cells(irow, icol).Value > 0) Then Cells(irow, icol).Value = a End If Next icol Next irow Columns("B").EntireColumn.Delete Columns("A:AZ").EntireColumn.AutoFit Call Macro3_FitTable End Sub Sub Macro3_FitTable() Dim LastRow As Long With ActiveSheet LastRow = .Range("B1").SpecialCells(xlCellTypeLastCell).Row End With Dim LastColumn As Long With ActiveSheet LastColumn = .Range("A1").SpecialCells(xlCellTypeLastCell).Column End With Dim b, temp b = 0 Dim groupRowNum For i = 4 To LastRow If Cells(i, 1) <> b And Cells(i, 1) > 0 Then b = Cells(i, 1) groupRowNum = i GoTo skipLoop End If temp = groupRowNum For icol = 2 To LastColumn If Cells(i, icol) <> 0 Then Do While temp < i If Cells(temp, icol) = 0 Then Cells(temp, icol).Value = Cells(i, icol) Cells(i, icol) = "" temp = i GoTo endLoop Else temp = temp + 1 End If endLoop: Loop End If Next icol skipLoop: Next i deletedRows = 0 For x = LastRow To 1 Step -1 If Application.WorksheetFunction.CountA(Rows(x)) = 0 Then Rows(x).Select Selection.Delete Shift:=xlUp deletedRows = deletedRows + 1 End If Next x Call Macro4_MergeAndColor(LastRow - deletedRows) End Sub Sub Macro4_MergeAndColor(LastRow As Long) Cells(1, 1).Value = "" Dim LastColumn As Long With ActiveSheet LastColumn = .Range("A3").SpecialCells(xlCellTypeLastCell).Column End With Range(Cells(4, 1), Cells(LastRow, 1)).Select With Selection.Font .Name = "Calibri" .Size = 12 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 .ThemeFont = xlThemeFontMinor End With With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 12611584 .TintAndShade = 0 .PatternTintAndShade = 0 End With Range(Cells(2, 2), Cells(3, LastColumn - 1)).Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark2 .TintAndShade = -9.99786370433668E-02 .PatternTintAndShade = 0 End With Range(Cells(2, 1), Cells(LastRow, LastColumn - 1)).Select With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With 'merge Groups vallindex = 4 For ind = 5 To LastRow If Cells(ind, 1) < 1 Then Range(Cells(vallindex, 1), Cells(ind, 1)).Select Selection.Merge With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlTop .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With End If vallindex = ind Next ind 'merge Family vallindex = 2 For ind = 3 To LastColumn - 1 If Cells(2, ind) < 1 Then Range(Cells(2, vallindex), Cells(2, ind)).Select Selection.Merge With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlTop .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With End If vallindex = ind Next ind Range(Cells(1, 1), Cells(LastRow, LastColumn - 1)).Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With Cells(1, 1).Select End Sub