论坛 › Office办公软件使用交流 › SQL+数据透视表+VBA 数据透视表的超级应用-多表查询

lnxxnchzyl 发表于 2009-9-15 12:18:28

SQL+数据透视表+VBA 数据透视表的超级应用-多表查询

在SQL+数据透视表+VBA 数据透视表的超级应用 帖子中很多人就期待多表查询的应用，今天就同大家见面了。
工作簿窗体代码：

工作簿关闭事件：将添加的数据透视表工具栏里面的数据透视表下拉菜单删除。工作簿存盘。

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
Call menu_del
ActiveWorkbook.Save
Application.DisplayAlerts = True
End Sub

工作簿打开事件：提取数据透视表中的SQL语句，通过调用其他过程提取用到的各个数据源的工作簿，查找带路径名称的工作簿是否存在，不存在的经过窗体显示出来，点击窗体中的对应按钮找到对应的工作簿，重新指向新的路径的工作簿，这样实现当你的数据源工作簿给任意移动后通过更新路径来使数据透视表仍然正确工作。
Private Sub Workbook_Open()
Call menu_add
SqlStr = ActiveSheet.PivotTables("数据透视表1").PivotCache.CommandText
Call checkfile
End Sub

模块2 中的代码：menu_add是添加菜单事件；menu_addmsg添加的菜单响应事件；menu_del删除菜单事件

Public i%, j%, n%, m%, SqlStr As String
Sub menu_add()
Dim cmb As CommandBarControl
n = Application.CommandBars("PivotTable").Controls("数据透视表(&P)").Controls.Count
For i = 1 To n
If Application.CommandBars("PivotTable").Controls("数据透视表(&P)").Controls(i).Caption = "查看或修改SQL语句" Then
Exit Sub
End If
Next
Set cmb = Application.CommandBars("PivotTable").Controls("数据透视表(&P)").Controls.Add(Type:=msoControlButton)
With cmb
.BeginGroup = True
.Caption = "查看或修改SQL语句"
.OnAction = "menu_addmsg"
.Visible = True
.FaceId = 159
End With
End Sub
Sub menu_addmsg()
UserForm2.Show
End Sub
Sub menu_del()
n = Application.CommandBars("PivotTable").Controls("数据透视表(&P)").Controls.Count
For i = 1 To n
If Application.CommandBars("PivotTable").Controls("数据透视表(&P)").Controls(i).Caption = "查看或修改SQL语句" Then
Application.CommandBars("PivotTable").Controls("数据透视表(&P)").Controls(i).Delete
End If
Next
End Sub

模块1中：

数据透视表刷新事件：
Data Source=" & ThisWorkbook.FullName 。。 数据源指向本工作簿
.Connection 里面的内容指向OLE DB 窗体中的连接
.CommandText = SqlStr 里面的内容指向OLE DB 窗体中的命令文本窗体SQL语句

Sub refreshpv()
    With ActiveSheet.PivotTables("数据透视表1").PivotCache
      .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 = ""
      .CommandText = SqlStr
    End With
    ActiveSheet.PivotTables("数据透视表1").PivotCache.Refresh
End Sub

获取那些工作簿已被移动
fnst(j)获取SQL语句中用到的工作表对应的工作簿，含重复工作簿
fls(m) 获取SQL语句中用到的不重复工作簿
Changenames(m) 获取那些被移动的工作簿

Function Sql_changefiles(ByVal SqlStr As String) As Variant
Dim fnst(), fls(), Filenames(), Changenames()
    n = Len(SqlStr) - Len(Replace(SqlStr, ":", ""))
    If n = 0 Then Sql_changefiles = Empty: Exit Function
    ReDim fnst(1 To n)
    m = 0
    For j = 1 To n
      p1 = InStr(p1 + 1, SqlStr, ":")
      p2 = InStr(p1 + 1, SqlStr, ".")
      
      fnst(j) = Mid(SqlStr, p1 - 1, p2 - p1) & ".xls"
    Next
    For j = 1 To n
      For k = 1 To j - 1
         If fnst(j) = fnst(k) Then GoTo 100
      Next
      ReDim Preserve fls(m)
      fls(m) = fnst(j)
      m = m + 1
100
    Next
m = 0
n = UBound(fls)
For i = 0 To n
    If Dir(fls(i)) = "" Then
    ReDim Preserve Changenames(m)
      Changenames(m) = fls(i)
      m = m + 1
    End If
Next
If m = 0 Then Exit Function
Sql_changefiles = Changenames
End Function

检查文件是否被移动，没有工作簿被移动就刷新纪录
如果有工作簿被移动，用msgbox 让你做选择：是、否、取消3个状态

Sub checkfile()
Dim OP, fls()
If Not IsArray(Sql_changefiles(SqlStr)) Then Call refreshpv: Exit Sub
fls = Sql_changefiles(SqlStr)
If UBound(fls) >= 0 Then
    OP = MsgBox("源文件已被移走，请选择下列选项" + Chr(10) + "1、选择是，重新输入文件全名" + Chr(10) + "2、选择否，打开原有的数据透视表,数据不刷新" + Chr(10) + "3、选择取消，关闭文件", vbYesNoCancel, "Scarlett温馨提示")
    If OP = vbYes Then
      UserForm1.Show
      Exit Sub
    End If
    If OP = vbNo Then
      Exit Sub
    End If
   
    If OP = vbCancel Then
      ActiveWorkbook.Close True
    End If
End If
End Sub

用户窗体1：
定义了一个类 newtpk 用数组来定义，让按钮和textbox做成一对类

Dim newtpk() As 类1
Dim arrmf()

确定按钮事件实现SQL语句字符串替换功能，并刷新数据透视表
Private Sub CommandButton2_Click()
For i = 0 To UBound(arrmf)
    If InStr(Controls("TBox" & i).Value, ".") > 0 Then
'    If InStr(Controls("TBox" & i).Value, ".") > 0 And Right(arrmf(i), Len(arrmf(i)) - InStrRev(arrmf(i), "\")) = Right(Controls("TBox" & i).Value, Len(Controls("TBox" & i).Value) - InStrRev(Controls("TBox" & i).Value, "\")) Then
         SqlStr = Replace(SqlStr, Replace(arrmf(i), ".xls", ""), Replace(Controls("TBox" & i).Value, ".xls", ""))
    Else
      MsgBox "文件名要带路径含后缀的文件名", , "Scarlett_88温馨提示"
      Controls("TBox" & i).Value = ""
      Controls("TBox" & i).SetFocus
      MsgBox "第" & i + 1 & "文本框不是文件全称，点击右边按钮选择正确的文件", , "信息提示"
      Exit Sub
    End If
Next
Call refreshpv
Unload Me
End Sub

退出按钮关闭窗体
Private Sub CommandButton3_Click()
Unload Me
End Sub

窗体初始化根据被移动的工作簿个数添加对应个数的控件组，并将旧的工作簿名称显示在标签控件中，对控件的属性进行设置，
Private Sub UserForm_Initialize()
Dim Tb As Object
Dim Cb As Object
Dim Lb1 As Object
Dim Lb2 As Object
arrmf = Sql_changefiles(SqlStr)
n = UBound(arrmf)
ReDim newtpk(n)
For i = 0 To n
    Set Lb1 = Controls.Add("forms.label.1", "Lbl1" & i, True)
    Set Tb = Controls.Add("Forms.textbox.1", "Tbox" & i, True)
    Set Cb = Controls.Add("Forms.commandbutton.1", "Combtn" & i, True)
    Set Lb2 = Controls.Add("forms.label.1", "Lbl2" & i, True)
    Lb1.Move 12, i * 100 + 58, 570, 25
    Lb2.Move 12, i * 100 + 110, 66, 18
    Tb.Move 78, i * 100 + 110, 510, 25
    Cb.Move 588, i * 100 + 110, 12, 27
    Set newtpk(i) = New 类1
    Set newtpk(i).tbox = Controls("Tbox" & i)
    Set newtpk(i).cbn = Controls("Combtn" & i)
    Lb1.Caption = "旧文件名：　　" & arrmf(i)
    Lb2.Caption = "新文件名"
    Tb.Text = ""
    Cb.Caption = ""
    Lb1.Font.Size = 12
    Lb2.Font.Size = 12
    Tb.Font.Size = 12
    Cb.BackColor = &HC0C0C0
    Tb.BackColor = &HE0E0E0
Next
    Controls("commandButton2").Top = UBound(arrmf) * 100 + 180
    Controls("commandButton3").Top = UBound(arrmf) * 100 + 180
    Me.Height = 250 + UBound(arrmf) * 100
End Sub

用户窗体2：

SqlStr = TextBox1.Text 将窗体中的SQL语句赋值给变量，
经过检查所用的工作簿是否存在后进行刷新数据透视表

Private Sub CommandButton1_Click()
SqlStr = TextBox1.Text
Call checkfile
Unload Me
End Sub

Private Sub CommandButton2_Click()
Unload Me
End Sub

窗体初始化时讲OLE DB 中的SQL语句赋值给textbox。
Private Sub UserForm_Initialize()
TextBox1.Text = ActiveSheet.PivotTables("数据透视表1").PivotCache.CommandText
End Sub

类模块中：

定义了两个类，一个textbox，一个按钮
Public WithEvents tbox As MSForms.TextBox
Public WithEvents cbn As MSForms.CommandButton

按钮类的单击事件：将选择的带路径的文件名赋值给textbox类
Private Sub cbn_Click()
On Error Resume Next
Dim num%
Dim fopen As FileDialog
Set fopen = Application.FileDialog(msoFileDialogFilePicker)
fopen.Show
If fopen.SelectedItems(1) = "" Then
    Exit Sub
Else
    tbox.Value = fopen.SelectedItems(1)
    Set fopen = Nothing
End If
End Sub

http://club.excelhome.net/images/GreenPark/attachimg.gif http://club.excelhome.net/attachment.php?aid=553180&k=4919dfcf75a5df49a706f52d954e2536&t=1252988224&noupdate=yes http://club.excelhome.net/images/attachicons/image.gif 1.JPG (160.47 KB)
2009-7-22 20:45



http://club.excelhome.net/images/GreenPark/attachimg.gif http://club.excelhome.net/attachment.php?aid=553181&k=92bb28784d93d3288ef1b2f7ffd2799c&t=1252988224&noupdate=yes http://club.excelhome.net/images/attachicons/image.gif 2.JPG (133.42 KB)
2009-7-22 20:45



http://club.excelhome.net/images/GreenPark/attachimg.gif http://club.excelhome.net/attachment.php?aid=553182&k=d884690a3c8156696c8064ecf4b48034&t=1252988224&noupdate=yes http://club.excelhome.net/images/attachicons/image.gif 3.JPG (169.58 KB)
2009-7-22 20:45



该文件的直接套用说明：
见倒数第二个图片：在数据透视表下拉有查看或修改SQL语句按钮，点击就会有一个窗体出来，你可以修改SQL语句，如果连字段都有改变，则需要你先将所有的字段都拖出透视表，新的SQL语句就能产生新的数据源，重新布局数据透视表即可。因为字段不同，透视表也就缺省字段，会出错。

查看完整版本: SQL+数据透视表+VBA 数据透视表的超级应用-多表查询