如何用vba使得数据透视表可以透视图片？

数据透视表本身只能透视单元格内容，如果单元格的内容是图片，同时满足以下几点，那么是可以借助vba实现透视图片。

1.每个单元格中存放的只有1个图片，不能既有图片又有文本；

2.每个图片都只存放在1个单元格内，不能存放跨越多个单元格；

3.图片要位于单元格内部，不能超出单元格的边界

如果可以同时满足以上几点，那么可以使用以下的思路实现数据透视表透湿图片的功能：

1.遍历将数据源单元格中存放的图片

2.将图片的名称存放于单元格内

3.在Workbook对象的SheetPivotTableUpdate事件或者SheetPivotTableChangeSync事件中遍历所有的透视表单元格区域，将含有图片名称的替换为图片。

4.同时需要考虑图片所在的列的列宽和行高问题

以下vba代码举例演示了如何借助vba实现数据透视表透湿图片的功能：

Public iMaxWidth
Public iMaxHeigth
Private Sub Workbook_SheetPivotTableUpdate(ByVal Sh As Object, ByVal Target As PivotTable)
    Call ShapePreTreatMent
    Dim oWK As Worksheet
    Set oWK = Sheet2
    Dim oP As Shape
    '先将之前的透视图片清空
    For Each oP In Sh.Shapes
        oP.Delete
    Next
    '预设行高和列宽
    Sh.RowS.RowHeight = iMaxHeigth
    Sh.Columns.ColumnWidth = 100
    Dim oPNew As Shape
    Dim oRng As Range
    With Target
        .HasAutoFormat = False
        .PreserveFormatting = False
        '获取数据透视表所占据的单元格区域
        Set oRng = .TableRange1
        Dim oCell As Range
        For Each oCell In oRng
            sText = oCell.Value
            '如果含有图片名称
            If sText Like "$*$" Then
                '则隐藏图片名称
                oCell.NumberFormat = ";;;"
                sText = VBA.Replace(sText, "$", "")
                Set oP = oWK.Shapes(sText)
                oP.Copy
                oCell.PasteSpecial xlPasteAl
                Set oPNew = Sh.Shapes(Sh.Shapes.Count)
                '调整图片的位置,实现透视图片
                With oPNew
                    .Left = oCell.Left
                    .Top = oCell.Top
                End With
            End If
        Next
    End With
End Sub
Sub ShapePreTreatMent()
    Dim oRngS As Range
    Dim oRngE As Range
    Dim oRng As Range
    Dim oSP As Shape
    Dim oWK As Worksheet
    Set oWK = Excel.ActiveSheet
    Dim arrWidth()
    Dim arrHeight()
    With oWK
        For Each oSP In .Shapes
            With oSP
                '图片不能是数据有效性的下拉列表按钮或者AX控件
                If .Type <> msoFormControl Then
                    '图片所在的单元格区域的左上角
                    Set oRngS = .TopLeftCell
                    '图片所在的单元格区域的右下角
                    Set oRngE = .BottomRightCell
                    '判断是否位于一个单元格内
                    Set oRng = Excel.Application.Intersect(oRngS, oRngE)
                    If oRng Is Nothing Then
                        MsgBox oRngS.Address & "有图片没有在一个单元格内"
                    Else
                        sText = oRng.Text
                        '判断是否既有图片又有文本
                        If Len(Trim(DoRegExp(sText, "\$.+\$", ""))) > 0 Then
                            MsgBox oRng.Address & "中既有图片又有文本，请全部转化为文本"
                        Else
                            oRng.Value = ""
                            oRng.Value = "$" & .Name & "$"
                            ReDim Preserve arrWidth(k)
                            ReDim Preserve arrHeight(k)
                            arrWidth(k) = oRng.Width
                            arrHeight(k) = oRng.Height
                            k = k + 1
                        End If
                    End If
                End If
            End With
        Next
    End With
    '获取所有图片占据的单元格的最大列宽
    iMaxWidth = Excel.Application.WorksheetFunction.Max(arrWidth)
    '获取所有图片占据的单元格的最大行高
    iMaxHeigth = Excel.Application.WorksheetFunction.Max(arrHeight)
End Sub
'sOrignText参数表示要执行正则表达式的字符串,sPattern 参数表示正则模式,sReplaceText参数表示要把找到的内容替换为的字符串
Function DoRegExp(ByVal sOrignText As String, ByVal sPattern As String, Optional sReplaceText As String = "")
    '定义正则表达式对象
    Dim oRegExp As Object
    '定义匹配字符串集合对象
    Dim oMatches As Object
    '定义匹配子字符串集合对象
    Dim oSubMatches As Object
    Dim oMatch As Object
    Dim str1 As String
    '创建正则表达式
    Set oRegExp = CreateObject("vbscript.regexp")
    With oRegExp
        '设置是否匹配所有的符合项，True表示匹配所有, False表示仅匹配第一个符合项
        .Global = True
        '设置是否区分大小写，True表示不区分大小写, False表示区分大小写
        .IgnoreCase = True
        '设置要查找的正则规则
        .Pattern = sPattern
        '判断是否可以找到匹配的字符，若可以则返回True
        If .Test(sOrignText) Then
'            对字符串执行正则查找，返回所有的查找值的集合，若未找到，则为空
            Set oMatches = .Execute(sOrignText)
'            For Each oMatch In oMatches
'                '返回匹配到的字符串的位置
'                Debug.Print oMatch.FirstIndex
'                '返回匹配到的字符串的长度
'                Debug.Print oMatch.Length
'                '返回子匹配结果
'                str1 = oMatch.SubMatches(0)
'            Next
'            DoRegExp = oMatches(0).Value
'            把字符串中用正则找到的所有匹配字符替换为其它字符
            DoRegExp = .Replace(sOrignText, sReplaceText)
        Else
            DoRegExp = sOrignText
        End If
    End With
    Set oRegExp = Nothing
    Set oMatches = Nothing
End Function