ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
EH云课堂-专业的职场技能充电站 限时送,魔方网表将Excel变在线系统 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 ExcelHome出品 - VBA代码宝免费下载 13门Excel免费公开课任你学
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 150783|回复: 489

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

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2009-7-22 20:43 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:数据透视表
在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

1.JPG

2.JPG

3.JPG

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


[ 本帖最后由 Scarlett_88 于 2009-8-31 04:05 编辑 ]

数据透视表VBA搜寻多表路径.rar

81.55 KB, 下载次数: 10287

评分

参与人数 3鲜花 +5 收起 理由
Excel实战分享 + 1 优秀作品
hope9966 + 2 感谢帮助
活雷锋赵升 + 2 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

发表于 2009-7-22 20:53 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2009-7-22 20:56 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2009-7-22 20:57 | 显示全部楼层
虽然对我来说太难了,但是还是要逼着自己学习一下,谢谢版主,辛苦了!

TA的精华主题

TA的得分主题

发表于 2009-7-22 21:01 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2009-7-22 21:04 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2009-7-22 21:18 | 显示全部楼层
原帖由 LangQueS 于 2009-7-22 20:56 发表
Scarlett_88 版辛苦了!


版版,你好富有哦

TA的精华主题

TA的得分主题

发表于 2009-7-22 21:42 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2009-7-23 13:12 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2009-7-23 13:22 | 显示全部楼层
本帖最后由 ExcelHome 于 2012-10-6 16:15 编辑

没有VB基础,总觉得学得有点力不从心!

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2019-1-20 13:09 , Processed in 0.116113 second(s), 13 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表