[已解决]不能打开数据透视表源文件

晨渡海棠

爱疯 发表于 2016-4-7 10:44
你的意思是不是：

还有很多象book2.xlsm、book3.xlsm的文件，

文件都是像附件这样的，然后sheet名和文件名一致，但是都不相同，且不是sheet1。请问可以自动获取吗？

爱疯

5.rar (133.1 KB, 下载次数: 8)

2016-4-7 11:38 上传

点击文件名下载附件


每个文件（即 excel 工作簿）数据源所在工作表，必须都在第n个工作表里。

比如，都是在第1个工作表，如果都在第3个工作表，就这么改

    Sheets(1).Activate
改为
    Sheets(3).Activate

晨渡海棠

爱疯 发表于 2016-4-7 11:22
每个文件（即 excel 工作簿）数据源所在工作表，必须都在第n个工作表里。

比如，都是在第1个工作表 ...

谢谢！竟然可以批量使用。
为了适用于csv文件，我刚刚试着将代码中的“f = Dir(p & "*.xls*")”改成了“f = Dir(p & "*.csv*")”，并在文件夹中放了一个csv文件。它可以生成透视表，奇怪的是，透视表没有出现在新的sheet中，而是将数据源给覆盖了。
还请帮忙看下，麻烦了。

爱疯

Sub test2()
    Dim p$, f$, fld$, saveAsPath
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    p = ThisWorkbook.Path & "\"
    fld = "MyFile"
    saveAsPath = p & fld & "\"
    If Dir(saveAsPath) = "" Then MkDir saveAsPath

    f = Dir(p & "*.csv*")    '为了用于csv文件，将.xls换成.csv
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            With Workbooks.Open(p & f)
                Call test1
                .SaveAs saveAsPath & VBA.Replace(f, ".CSV", ""), 51
                .Close False
            End With
        End If
        f = Dir
    Loop

    Shell "explorer " & saveAsPath, vbNormalFocus
End Sub


Sub test1()
    Dim data As Range
    Dim pc As PivotCache
    Dim pt As PivotTable
    Dim A

    '指定数据源
    Sheets(1).Activate
    A = [A1].CurrentRegion
    Set data = Range([A2], Cells(UBound(A), UBound(A, 2)))

    '创建空白工作表，存放数据透视表。
    Sheets.Add after:=Sheets(Sheets.Count)
    '创建 数据透视表的缓存（PivotCache 对象）
    Set pc = ActiveWorkbook.PivotCaches.Create(xlDatabase, data, xlPivotTableVersion11)    'Excel 2003
    '创建一个基于 数据透视表的缓存（PivotCache 对象）的数据透视表。透视表左上角在A1
    Set pt = pc.CreatePivotTable([A1])
    With pt
        '1）行
        '透视字段"PRT_NO"的位置在 行
        .PivotFields("PRT_NO").Orientation = xlRowField
        '透视字段"SULN"的位置在 数值
        .PivotFields("SULN").Orientation = xlDataField
    End With
End Sub






6.rar (16.17 KB, 下载次数: 8)

2016-4-7 15:25 上传

点击文件名下载附件

改了下，这样可以吗

晨渡海棠

爱疯 发表于 2016-4-7 15:25
Sub test2()
    Dim p$, f$, fld$, saveAsPath
    Application.ScreenUpdating = False

很好用了，谢谢！