在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
|