读取透视表字段，生成新数据

erorpqitp

本来是有这个需求，就是数据透视表透视字段名每月一样，但是数据源字段排列的顺序每个月不稳定。我就想搞个窗体，读取原透视表的排列，然后引入新数据，自动生产透视表。写了一会，被excle版本，和wps不兼容，搞得烦死了。不知道这个需求有没有价值，发了半成品上来。还有就是我激活窗体，换其他表格读取数据源的时候，窗体只显示在原先的表上，没有显示在新的表上。看看有没有大佬帮忙解决一下。

WANT-T

首先你的这个需求是有价值的，但是这个价值被市面上的BI工具实现了；
其次，你的问题有点多，且没有头绪，同时也没有逻辑，说明你并不清楚自己要什么，需要再梳理一下!
VBA操作透视表是有现成的案例可循的；
VBA自动化报表也是有现成的案例的，包括自动导入数据源功能（数据源一致）；
数据源不稳定是不可以的，必须一致，要定模板，定标准，别给自己找麻烦；
Excel版本问题，要稳定，OFFICE就是OFFIC,WPS就是WPS,MAC就是MAC,不要妄想兼容；
做自动化报表起码要对数据结构要有一定的了解，了解以后就不会再纠结顺序了！
激活窗体后，换表格读取数据，窗体只显示在原先的表上，这是没有问题的，因为窗体就在原来的表格上，所以没有毛病；为什么没有显示在新的表上，因为它是原来的表格上的窗体! 怎么能让它切换到新表呢？按加载宏的标准要求重新开发!
送你一个案例，之前帮论坛里的某兄弟开发的，VBA生成透视表！
回复：工作簿1-20230506.zip (24.85 KB, 下载次数: 4)

2023-5-30 16:38 上传

点击文件名下载附件

如果你能看明白，就会发现，压根就不需要什么透视表，一句SQL的事；

祝您生活愉快，再见！

wengjl

你的问题用VBA解决是不难的，就是你说的顺序每个月不稳是怎么个不稳法？从附件中看不出来

3190496160

这个问题，就没有必要追求透视表，直接用vba代码实现数据透视表的效果不就行了吗？
即使你每个月的数据源的字段排列顺序不一样，也是可以解决的嘛，用字典来判断不就行了吗

3190496160

Private Sub CommandButton1_Click()
With ListBox1
    For i = 0 To .ListCount - 1
        .Selected(i) = True
    Next i
End With
End Sub

Private Sub CommandButton2_Click()
With ListBox1
    For i = 0 To .ListCount - 1
        .Selected(i) = False
    Next i
End With
End Sub

Private Sub CommandButton3_Click()
With ListBox1
    For i = 0 To .ListCount - 1
        If .Selected(i) = True Then
            .Selected(i) = False
        Else
            .Selected(i) = True
        End If
    Next i
End With
End Sub

Private Sub CommandButton4_Click()
Dim ar As Variant, br As Variant
Dim rn As Range
Dim i As Long, r As Long, yy As Long
Dim d As Object, dc As Object
Dim rr()
ReDim rr(1 To ListBox1.ListCount)
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
With ActiveSheet
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    yy = .Cells(3, Columns.Count).End(xlToLeft).Column
    zd = Trim(.[b1])
    If r > 3 Then .Range(.Cells(4, 1), .Cells(r, yy)).Clear
    br = .Range(.Cells(3, 1), .Cells(50000, yy))
    For j = 2 To UBound(br, 2)
        If Trim(br(1, j)) <> "" Then
            d(Trim(br(1, j))) = j
        End If
    Next j
    With ListBox1
        For i = 0 To .ListCount - 1
            If .Selected(i) = True Then
                n = n + 1
                dic(.List(i, 0)) = ""
            End If
        Next i
    End With
    If n = "" Then MsgBox "请选择要汇总的单号！": Exit Sub
    k = 1
    For Each sh In Sheets
        If sh.Name <> "求和" Then
            ar = sh.[a1].CurrentRegion
            Set rn = sh.Rows(1).Find("生产任务单号", , , , , , 1)
            If rn Is Nothing Then MsgBox sh.Name & "中没有生产任务单号字段！": End
            y = rn.Column
            For i = 2 To UBound(ar)
                If Trim(ar(i, y)) <> "" Then
                    If dic.exists(Trim(ar(i, y))) Then
                        T = dc(Trim(ar(i, y)))
                        If T = "" Then
                            k = k + 1
                            dc(Trim(ar(i, y))) = k
                            T = k
                            br(k, 1) = ar(i, y)
                        End If
                        For j = 1 To UBound(ar, 2)
                            lh = d(Trim(ar(1, j)))
                            If lh <> "" Then
                                br(T, lh) = br(T, lh) + ar(i, j)
                            End If
                        Next j
                    End If
                End If
            Next i
        End If
    Next sh
    If k = 1 Then MsgBox "没有符合具体的数据！": End
    .[a3].Resize(k, UBound(br, 2)) = br
End With
MsgBox "ok!"
End Sub
Private Sub UserForm_Initialize()
Dim ar As Variant
Dim rn As Range
Dim i As Long
Dim d As Object
Set dic = CreateObject("scripting.dictionary")
For Each sh In Sheets
    If sh.Name <> "求和" Then
        Set rn = sh.Rows(1).Find("生产任务单号", , , , , , 1)
        If rn Is Nothing Then MsgBox sh.Name & "中没有生产任务单号字段！": End
        y = rn.Column
        ar = sh.[a1].CurrentRegion
        For i = 2 To UBound(ar)
            If Trim(ar(i, y)) <> "" Then
                dic(Trim(ar(i, y))) = ""
            End If
        Next i
        Set rn = Nothing
    End If
Next sh
Me.ListBox1.List = dic.keys
Set dic = Nothing
End Sub

3190496160

仅供参考
工作簿1.rar (80.54 KB, 下载次数: 1)

2023-5-31 08:57 上传

点击文件名下载附件