VBA建立SQL的透视表设置存放位置问题

软件爱好者

那位高手能帮我把VBA建立的透视表,固定放到某个变量位置!  
刚发现的主要现象:当新建一个透视表后,再将路径改成变量,前题是刚建的透视表不能删除,创建透视表到变量位置又正常得很了.      
变量,需要固定的位置:
MC = Worksheets(Sheet3.Name).Cells(5, 1).Address(1, 1, 2, 1)
下面代码为新建工作表后,放置透视表(需改成上面的变量地址):
.CreatePivotTable TableDestination:="", TableName:=PtNameI, _
                DefaultVersion:=xlPivotTableVersion10

完整代码:
Sub PtTable()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim S1Rng, S2Rng, s1Address, s2Address, BT1, BT2, BT3, BT4, Sqla, Sqlb, i, MC, PtNameI
   'On Error Resume Next
    Application.DisplayAlerts = False
        Set Sh1 = Sheet1
        Set Sh2 = Sheet2
        Set S1Rng = Sh1.Range("S2").CurrentRegion '款号标题
        Set S2Rng = Sh2.Range("S2").CurrentRegion '款号标题
        s1Address = S1Rng.Offset(1, 0).Address(0, 0)
        s2Address = S2Rng.Offset(1, 0).Address(0, 0)
        BT1 = Sh1.Range("A2").Value '日期标题
        BT2 = Sh1.Range("S2").Value '款号标题
        BT3 = Sh1.Range("L2").Value '工序标题
        BT4 = Sh1.Range("N2").Value '数量标题
        Sqla = " Select * FROM [" & Sh1.Name & "$" & s1Address & "]"
        Sqlb = " Select * FROM [" & Sh2.Name & "$" & s2Address & "]"
        For i = 1 To ActiveSheet.PivotTables.Count '删除现有的透视表
            ActiveSheet.PivotTables(i).TableRange2.Clear
        Next
    With ActiveWorkbook.PivotCaches.Add(SourceType:=xlExternal)
        .Connection = Array( _
       "OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;User ID=Admin;Data Source=" & ThisWorkbook.FullName & ";Mode=Share Deny Write;Extended P" _
       , _
       "roperties=""HDR=YES;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Type=35;Jet OLEDB:Database Locking" _
       , _
       " Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password="""";Jet OLEDB:Cr" _
       , _
       "eate System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Witho" _
       , "ut Replica Repair=False;Jet OLEDB:SFP=False")
        .CommandType = xlCmdTable
        .CommandText = Array(Sqla & " union all " & Sqlb)
        .MaintainConnection = True
        ''------------------------------上面代码正常
        PtNameI = "PivotTables1"
    MC = Worksheets(Sheet3.Name).Cells(5, 1).Address(1, 1, 2, 1)
        .CreatePivotTable TableDestination:="", TableName:=PtNameI, _
        DefaultVersion:=xlPivotTableVersion10
    End With
       ''------------------------------下面代码也正常
        ActiveWorkbook.ShowPivotTableFieldList = True
    With ActiveSheet.PivotTables(PtNameI).PivotFields(BT1)
        .Orientation = xlColumnField
        .Position = 1
    End With
    With ActiveSheet.PivotTables(PtNameI).PivotFields(BT2)
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables(PtNameI).PivotFields(BT3)
        .Orientation = xlRowField
        .Position = 2
    End With
    ActiveSheet.PivotTables(PtNameI).AddDataField ActiveSheet.PivotTables(PtNameI _
        ).PivotFields(BT4), BT4 & "Sum", xlSum

    Cells.Font.Size = 10
    Cells.EntireColumn.AutoFit
    Application.DisplayAlerts = True
    'On Error GoTo 0
End Sub

附件:
VBA建SQL透视表.rar (33.13 KB, 下载次数: 34)

2011-3-1 21:13 上传

点击文件名下载附件

[ 本帖最后由 软件爱好者 于 2011-3-2 08:04 编辑 ]

软件爱好者

没人路过吗,很难吗?