Trying to copy source data formatting to pivot table cell-by-cell with VBA in Excell 2007

[Rick.M]

Hi,

I'm hoping one of you VBA Gurus can help me figure out how to accomplish what I am trying to do. As I'm sure you are painfully aware that Pivot Table cell values do not adopt source data formatting. I am looking for a way to update my pivot table cells to with the font color of the corresponding cell in the source data. I found some code posted on another site (datapig.com) that allows me to update formatting from source data at field level by column but it doesn't go down to the cell level.

I figure will need to loop through both the source data and pivot table cells to obtain formatting values from source cells and update the corresponding pivot table cell. Specifically, my goal is to preserve the font colors of the source data and display them in the pivot table.

I've included example source data and pivot table below (hope I did it right since this is my first attempt)...

Here is my source data with data range in multiple font colors:

Excel 2007

	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA
1	Region	Geo	Customer	Project	Product Line	PASID	Consultant	Employee ID	Cust Rate	Sub Rate	Manager/Partner	Type	10/06	10/13	10/20	10/27	11/03	11/10	11/17	11/24	12/01	12/08	12/15	12/22	12/29	12/31	Total Booked SOW
2	Previously Booked		Holiday	Holiday	Admin		Billy-Bob	123456			Hair-Pointy	Own								16					8
3	Central		Customer 1	Project x	Product 1	2315379	Billy-Bob	123456			Hair-Pointy	Own		16	16	16											36918
4	Central		Customer 1	Project x2	Product 1	2317288	Billy-Bob	123456			Hair-Pointy	Own					12	12	12	12							40500
5	West Coast		Customer 2	Project Y	Product 1	2287895	Billy-Bob	123456			Hair-Pointy	Own	6	14	14	14											47520
6	Previously Booked		US Vacation	Vacation	Admin		Bobby-Sue	123457			Hair-Pointy	Own	32
7	Previously Booked		Holiday	Holiday	Admin		Bobby-Sue	123457			Hair-Pointy	Own								16					8
8	Central		Customer 1	Project x	Product 1	2315379	Bobby-Sue	123457			Hair-Pointy	Own		32	32	32											36918
9	Central		Customer 1	Project x2	Product 1	2317288	Bobby-Sue	123457			Hair-Pointy	Own					32	32	32	32							40500
10	West Coast		Internal	Internal IPR	Admin	2292683	Bobby-Sue	123457			Hair-Pointy	Own		20

<tbody>
</tbody>

Q4 Data​

Pivot Table (font colors gone):

Excel 2007

	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
3		Values
4	Row Labels	10/06	10/13	10/20	10/27	11/03	11/10	11/17	11/24	12/01	12/08	12/15	12/22	12/29	12/31
5	Hair-Pointy
6	Billy-Bob	6	30	30	30	12	12	12	28					8
7
8	Customer 1
9	2315379		16	16	16
10	Project x		16	16	16
11	2317288					12	12	12	12
12	Project x2					12	12	12	12
13	Customer 2
14	2287895	6	14	14	14
15	Project Y	6	14	14	14
16	Holiday
17									16					8
18	Holiday								16					8
19	Bobby-Sue	32	52	32	32	32	32	32	48					8
20
21	Customer 1
22	2315379		32	32	32
23	Project x		32	32	32
24	2317288					32	32	32	32
25	Project x2					32	32	32	32
26	Holiday
27									16					8
28	Holiday								16					8
29	Internal
30	2292683		20
31	Internal IPR		20
32	US Vacation
33		32
34	Vacation	32
35	Grand Total	38	82	62	62	44	44	44	76					16

<tbody>
</tbody>

Q4 Util by Consultant​

Also included is the VBA code that works at the column level. Not sure if this can be modified to go down the cell level or if it would be easier to start from scratch:

Public Sub format_pivots()
AdoptSourceFormatting
format_zero_valued_cells
End Sub
Public Sub format_zero_valued_cells()
Dim rngPTData As Range
Dim RngCell As Range
Dim RngSrcData As Range

Set rngPTData = ActiveSheet.PivotTables(1).DataBodyRange
     'set start cell for find
Set RngCell = rngPTData.Cells(1)
Application.ScreenUpdating = False
For Each RngCell In rngPTData
  If RngCell.Value = 0 Then
    RngCell.Font.ColorIndex = 37
  End If
Next RngCell
Application.ScreenUpdating = True
Set rngPTData = Nothing
Set RngCell = Nothing
End Sub
 
Public Sub format_booked_value()
Application.ScreenUpdating = False
ActiveSheet.PivotTables(1).PivotSelect "'Booked Value'[All]", _
        xlLabelOnly + xlFirstRow, True
    Selection.NumberFormat = "$#,##0"
Application.ScreenUpdating = True

End Sub
Sub AdoptSourceFormatting()
'Mike Alexander
'www.datapigtechnologies'
'Be sure you start with your cursor inside a pivot table.
Dim oPivotTable As PivotTable
Dim oPivotFields As PivotField
Dim oSourceRange As Range
Dim strLabel As String
Dim strFormat As String
Dim strFontColor As String
Dim i As Integer
On Error GoTo MyErr
'Identify PivotTable and capture source Range
    Set oPivotTable = ActiveSheet.PivotTables(ActiveCell.PivotTable.Name)
    Set oSourceRange = Range(Application.ConvertFormula(oPivotTable.SourceData, xlR1C1, xlA1))
'Refresh PivotTable to synch with latest data
    oPivotTable.PivotCache.Refresh
'Start looping through the columns in source range
    For i = 1 To oSourceRange.Columns.Count
    
    'Trap the column name and number format for first row of the column
        strLabel = oSourceRange.Cells(1, i).Value
        strFormat = oSourceRange.Cells(2, i).NumberFormat
        strFontColor = oSourceRange.Cells(2, i).Font.ColorIndex
    
    'Now loop through the fields PivotTable data area
        For Each oPivotFields In oPivotTable.DataFields
   
        'Check for match on SourceName then appply number format if there is a match
            If oPivotFields.SourceName = strLabel Then
            oPivotFields.NumberFormat = strFormat
            'oPivotFields.Font.ColorIndex = strFontColor (doesn't work becaue this is at field level not cell level)
                    'Bonus:  Change the name of field to Source Column Name
            oPivotFields.Caption = strLabel & " "
            End If
        
        Next oPivotFields
    Next i
Exit Sub
'Error stuff
MyErr:
If Err.Number = 1004 Then
MsgBox "You must place your cursor inside of a pivot table."
Else
MsgBox Err.Number & vbCrLf & Err.Description
End If
End Sub

Any Assistance will be greatly appreciated...

Rick

 

[Rick.M]

I couldn't figure out how to post the data table and have the colors show up so I'm posting an image instead. Hope this works.

https://picasaweb.google.com/116086651057757101332/DropBox?authuser=0&feat=directlink