zhendeaini

原帖由 ghunter 于 2014-10-21 09:50 发表
此表有两个表，1。输出表（所有的资料都在输出表中体现）；2。数据表（原始数据）
要求：
1.从输出表的第二行开始输出所需要的数据。
2.输出表的右边黄色标记的地方为下拉列表框，此处可对数据表中的数据进行筛选，点击后会对数据表进行筛选，结果在输出表的第二行开始实时输出。
3.下拉列表框中的数据，从数据表中实时生成，如：数据表中，性别如果只有男性，则输出表的对应下拉列表中的选项只有男性，例表中，输出表班级的下拉列表框中的数据应为：101，102，103，104，201，305.
4.按要求输出指定的数据，如果没有指定，则输出全部数据。


原帖地址：http://150.48.48.12/BBS/viewthread.php?tid=16072&extra=page%3D1

思路：
1、获取多选项下拉列表的选项，方法：先在sheet2中设置辅助列，利用高级筛选功能，录制宏（工具→宏→录制新宏），得到唯一值（各列不重复值）。然后利用Worksheet_Change事件，实时更新下拉选项。
2、利用数据有效性得到多选项下拉列表的选项。
3、编写好代码，点击“CommandButton1”命令按钮，得到值。

                                                                                                                                                        ——by zhendeaini 22,Oct.,2014

[ 本帖最后由 zhendeaini 于 2014-10-22 13:51 编辑 ]

ghunter

引用:

原帖由 zhendeaini 于 2014-10-22 13:15 发表
原帖由 ghunter 于 2014-10-21 09:50 发表
此表有两个表，1。输出表（所有的资料都在输出表中体现）；2。数据表（原始数据）
要求：
1.从输出表的第二行开始输出 ...

不错，做得很好~
相当厉害啊~~神一般的存在~

zhendeaini

引用:

原帖由 ghunter 于 2014-10-22 13:18 发表

不错，做得很好~
相当厉害啊~~神一般的存在~

不敢，很多不懂的啊！像此案例中涉及到SQL查询语句。

ghunter

能详细地写一篇教学文，手把手教一教我做法，好吗？

zhendeaini

引用:

原帖由 ghunter 于 2014-10-22 15:39 发表
能详细地写一篇教学文，手把手教一教我做法，好吗？

这个比较多哦，最近工作也比较忙。我公开代码吧：
第一步是录制宏，目的是得到唯一值（各列不重复值）

Option Explicit
Sub 高级筛选—姓名()
'
' 高级筛选—姓名 Macro
' 宏由 zhendeaini 录制，时间: 2014-10-21
'
'
    Sheet2.Select
    Columns("A:A").Select
    Sheet2.Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns( _
        "K:K"), Unique:=True
End Sub

Option Explicit
Sub 高级筛选—班级()
'
' 高级筛选—班级 Macro
' 宏由 zhendeaini 录制，时间: 2014-10-21
'
'
    Columns("B:B").Select
    Sheet2.Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns( _
        "L:L"), Unique:=True
End Sub

Option Explicit

Sub 高级筛选—学号()
'
' 高级筛选—学号 Macro
' 宏由 zhendeaini 录制，时间: 2014-10-21
'
'
    Columns("C:C").Select
    Sheet2.Columns("C:C").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns( _
        "M:M"), Unique:=True
End Sub


Option Explicit
Sub 高级筛选—入学年月()
'
' 高级筛选—入学年月 Macro
' 宏由 zhendeaini 录制，时间: 2014-10-21
'
'
    Columns("D:D").Select
    Sheet2.Columns("D:D").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns( _
        "N:N"), Unique:=True
End Sub

Option Explicit
Sub 高级筛选—性别()
'
' 高级筛选—喜好 Macro
' 宏由 zhendeaini 录制，时间: 2014-10-21
'
'
    Columns("E:E").Select
    Sheet2.Columns("E:E").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns( _
        "O:O"), Unique:=True
End Sub



Option Explicit
Sub 高级筛选—喜好()
'
' 高级筛选—喜好 Macro
' 宏由 zhendeaini 录制，时间: 2014-10-21
'
'
    Columns("F:F").Select
    Sheet2.Columns("F:F").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns( _
        "P:P"), Unique:=True
End Sub



Option Explicit
Sub 高级筛选—数据1()
'
' 高级筛选—数据1 Macro
' 宏由 zhendeaini 录制，时间: 2014-10-21
'
'
    Columns("G:G").Select
    Sheet2.Columns("G:G").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns( _
        "Q:Q"), Unique:=True
End Sub


Option Explicit
Sub 高级筛选—数据2()
'
' 高级筛选—数据2 Macro
' 宏由 zhendeaini 录制，时间: 2014-10-21
'
'
    Columns("H:H").Select
    Sheet2.Columns("H:H").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns( _
        "R:R"), Unique:=True
    Range("A1").Select
End Sub

zhendeaini

引用:

原帖由 ghunter 于 2014-10-22 15:39 发表
能详细地写一篇教学文，手把手教一教我做法，好吗？

第二步，设置下拉列表

由于引用了sheet2数据，所以先Ctrl+F3，定义名称，以便设置数据有效性时候引用。

比如说：设置名姓名=OFFSET(数据表!$K$2,,,COUNTA(数据表!$K:$K))
以此类推设置好

点击“数据”→ “有效性”→有效性条件选择“序列”输入=名称
以此类推设置好

zhendeaini

引用:

原帖由 ghunter 于 2014-10-22 15:39 发表
能详细地写一篇教学文，手把手教一教我做法，好吗？

第三步：书写代码
Alt+F11打开VB编辑器或者“工具”→“宏”→Visual Basic编辑器

1、先在左边的ThisWorkBook输入Workbook_Open触发事件
Private Sub Workbook_Open()
Sheet1.Activate
Dim sht As Worksheet
Set sht = ActiveSheet
Application.ScreenUpdating = False
Call 高级筛选—姓名
Call 高级筛选—班级
Call 高级筛选—学号
Call 高级筛选—入学年月
Call 高级筛选—性别
Call 高级筛选—喜好
Call 高级筛选—数据1
Call 高级筛选—数据2
sht.Select
Sheet1.[K1] = ""
Sheet1.[L1] = ""
Sheet1.[M1] = ""
Sheet1.[N1] = ""
Sheet1.[O1] = ""
Sheet1.[P1] = ""
Sheet1.[Q1] = ""
Sheet1.[R1] = ""
Application.ScreenUpdating = True
End Sub
意思是当你打开Excel的时候自动运行宏代码

2、在sheet2工作表（数据表）中输入Worksheet_Change触发事件，目的是当你在sheet2工作表更改数据的时候自动更新宏代码。简单地说做到实时更新。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ChgArea As Range
    Dim ChgCell As Range
    Dim ChgAdd As String
    Set ChgArea = Range("A2:H10000")
    For Each ChgCell In ChgArea
        ChgAdd = ChgCell.Address
        If Target.Address = ChgAdd Then
            'MsgBox "注意：内容有变化，请确认！", vbExclamation
        Dim sht As Worksheet
        Set sht = ActiveSheet
        Application.ScreenUpdating = False
          Call 高级筛选—姓名
          Call 高级筛选—班级
          Call 高级筛选—学号
          Call 高级筛选—入学年月
          Call 高级筛选—性别
          Call 高级筛选—喜好
          Call 高级筛选—数据1
          Call 高级筛选—数据2
        Application.ScreenUpdating = True
        End If
    Next
End Sub

3、在sheet1工作表（输出表）书写CommandButton1命令按钮代码，这是实现你所需的功能的关键代码。

Option Explicit
Private Sub CommandButton1_Click()
    'Dim CNN As New ADODB.Connection
    'Dim RST As New ADODB.Recordset
    Dim CNN, strsql$, aa, HH, BB, CC, DD, JJ, KK
    Set CNN = CreateObject("adodb.connection")
    'Dim strsql$
    Dim i&, t&
    Application.ScreenUpdating = False
    t = Sheet1.Range("A65536").End(xlUp).Row
    CNN.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
    If Sheet1.[K3] <> "" Then
        aa = " and 班级 like '%" & Sheet1.[K3] & "%'"
    End If
    If Sheet1.[K4] <> "" Then
        HH = " AND 学号 like '%" & Sheet1.[K4] & "%'"
    End If
    If Sheet1.[K5] <> "" Then
        BB = " AND 入学年月 like '%" & Sheet1.[K5] & "%'"
    End If
    If Sheet1.[K6] <> "" Then
        CC = " AND 性别 like '%" & Sheet1.[K6] & "%'"
    End If
    If Sheet1.[K7] <> "" Then
        DD = " AND 喜好 like '%" & Sheet1.[K7] & "%'"
    End If
    JJ = aa & BB & HH & CC & DD
    If Len(JJ) Then KK = "WHERE " & Mid(JJ, 6, 888)
    strsql = "select 姓名,班级,学号,入学年月,性别,喜好,数据1,数据2 FROM [数据表$A:H] " & KK
    Sheet1.Range("A2").CurrentRegion.ClearContents
    Sheet1.Range("A1:H1") = Sheet2.Range("A1:H1").Value
    Sheet1.[A2].CopyFromRecordset CNN.Execute(strsql)
    CNN.Close
    Set CNN = Nothing
    Application.ScreenUpdating = True
End Sub

至此，程序完毕！到目前为止，没有发现错误。

ghunter

牛人啊~~

seaxin

学习下，虽然还用不上～[39]

maximus

牛。太有心了。

ghunter

有没有关于EXCEL宏的这方面的书推荐几本？！谢谢

ghunter

这是一篇好文，建议长期置顶~

zhendeaini

引用:

原帖由 ghunter 于 2014-10-23 08:58 发表
有没有关于EXCEL宏的这方面的书推荐几本？！谢谢

这个有很多的，要注意的是Excel 2003和比Excel 2003更高级版本的编程代码是有些许不同，因为控件名称不同了。（Office 2003基于Visual Basic 6.0而成的编程环境，目前Visual Basic 6.0已经逐步退出历史舞台，Visual Basic.NET登台出场），在2003环境下完美运行的，在其他版本不一定能够完美运行。

ghunter

引用:

原帖由 zhendeaini 于 2014-10-23 10:26 发表


这个有很多的，要注意的是Excel 2003和比Excel 2003更高级版本的编程代码是有些许不同，因为控件名称不同了。（Office 2003基于Visual Basic 6.0而成的编程环境，目前Visual Basic 6.0已经逐步退出历史舞台，Vis ...

的确如此，我在2003下用数据库链接的方式导入外部数据，用SQL做查询，在2013下用不了。。。也同样能做出类似的效果，但明显没有你的方法简便易懂
我的办法就是每次都更新导入外部数据，而所谓的外部数据就是表2.

zhendeaini

引用:

原帖由 ghunter 于 2014-10-23 11:01 发表


的确如此，我在2003下用数据库链接的方式导入外部数据，用SQL做查询，在2013下用不了。。。也同样能做出类似的效果，但明显没有你的方法简便易懂
我的办法就是每次都更新导入外部数据，而所谓的外部数据就是表2 ...

其实，这里采用了辅助列这一概念，目的是能实时更新下拉选项！有时候采用直接的方法不行，那就换位思考下，能否婉转表达。[39]

ghunter

引用:

原帖由 zhendeaini 于 2014-10-23 17:15 发表


其实，这里采用了辅助列这一概念，目的是能实时更新下拉选项！有时候采用直接的方法不行，那就换位思考下，能否婉转表达。[39]

我也做了辅助列，辅助列A由导入外部数据生成，每次更新数据表时会自动更新，使用列表框列出筛选出来的值，选定值再返回到辅助列B中。

zhendeaini

引用:

原帖由 ghunter 于 2014-10-24 08:50 发表


我也做了辅助列，辅助列A由导入外部数据生成，每次更新数据表时会自动更新，使用列表框列出筛选出来的值，选定值再返回到辅助列B中。

[12]