常用工具系列之一（自动查询）

little-key · 发表于 2009-11-22 20:48

隐藏跟帖

【开发初衷】
1、查询是Excel使用者用得最多的功能之一；
2、让更多的初学者不会查询函数也可以用查询功能；
3、当数据量比较大时提高效率；
4、多条件查询；
5、多列结果查询；
6、多条件和多列结果查询；

基于以上这些问题，特开发此工具，希望这个工具能给大家在工作生活中带来力所能及的帮助，这也是我们希望看到的。

【预览和简介】：
第一版：

主界面预览图

第二版：移动有两种形式，请大家议议哪个比较好。

【试用下载】：

常用工具6.0版.rar (197.73 KB, 下载次数: 6872)
见附件里的字典查询,

2003加载宏下载地址：http://club.excelhome.net/viewth ... ;page=18#pid3423818

【开发团队】：
主创人员：彭希仁（彭希遴）
团队成员：little-key（梁才）

【更新日志】：
2009年11月22日
快速查询；
自定义忽略标题行；

注：
+ 表示增加功能
- 表示减少功能
* 表示修改功能
# 表示优化功能

[ 本帖最后由 little-key 于 2009-12-30 00:28 编辑 ]

little-key · 发表于 2009-11-22 20:49

【使用说明】
一、结果为单列的查询
单列查询.gif

二、结果为多列的查询
结果为多列.gif

三、条件为单列的查询
条件为单列.gif

四、条件为多列的查询
多条件查询.gif

五、忽略标题的查询

六、横向查询

七、向左查询

[ 本帖最后由 little-key 于 2009-11-22 22:18 编辑 ]

little-key · 发表于 2009-11-22 20:50

【开发过程】
一：界面设计

二、代码设计
（1）工作表代码
如果需要使用快捷启动（建议），则请在ThisWorkbook中添加以下代码：

Private Sub Workbook_Open()
On Error Resume Next
Application.OnKey "^w", "右键字典"
End Sub

复制代码

（2）窗体代码

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const WS_THICKFRAME As Long = &H40000
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_MAXIMIZEBOX As Long = &H10000
Private Sub CheckBox1_Click()
On Error GoTo ren
If CheckBox1.Value = False And ref(1) <> "" Then
Set myc.sht = Nothing
Set myc = Nothing
ref(1) = ""
ref(5) = ""
ref(6) = ""
ref(7) = ""
ref(8) = ""
ref(9) = ""
ref(2) = ""
ref(3) = ""
Set ref(4) = Nothing
End If
ren:
End Sub
Private Sub CheckBox2_Click()
End Sub
Private Sub CheckBox3_Click()
If CheckBox3.Value Then
ref(10) = 0
Else
ref(10) = 1
End If
End Sub
Private Sub CommandButton2_Click()
RefEdit2.Text = ""
RefEdit1.Text = ""
RefEdit3.Text = ""
RefEdit4.Text = ""
End Sub
Private Sub CommandButton3_Click()
Unload Me
End Sub
Private Sub RefEdit1_BeforeDragOver(Cancel As Boolean, ByVal Data As MSForms.DataObject, ByVal x As stdole.OLE_XPOS_CONTAINER, ByVal y As stdole.OLE_YPOS_CONTAINER, ByVal DragState As MSForms.fmDragState, Effect As MSForms.fmDropEffect, ByVal Shift As Integer)
End Sub
Private Sub RefEdit3_Change()
On Error GoTo ren
If RefEdit1.Text <> "" Then
If Range(RefEdit1.Text).Rows.Count < Range(RefEdit1.Text).Columns.Count Then OptionButton2.Value = True
End If
ren:
End Sub
Private Sub UserForm_Activate()
If ref(10) = 1 Then
RefEdit2.Text = ""
RefEdit1.Text = ""
RefEdit3.Text = ""
RefEdit4.Text = ""
End If
If ref(10) = "" Then
CheckBox3.Value = False '如果启动默认为勾选的话，则修改为True
ref(10) = 1 '如果启动默认为勾选的话，则删除此句
ElseIf ref(10) = 0 Then
CheckBox3.Value = True
Else
CheckBox3.Value = False
End If
End Sub
Private Sub UserForm_Initialize()
Dim hWndForm As Long
Dim IStyle As Long
hWndForm = FindWindow("ThunderDFrame", Me.Caption)
IStyle = GetWindowLong(hWndForm, GWL_STYLE)
IStyle = IStyle Or WS_THICKFRAME
IStyle = IStyle Or WS_MINIMIZEBOX
IStyle = IStyle Or WS_MAXIMIZEBOX
SetWindowLong hWndForm, GWL_STYLE, IStyle
OptionButton1.Value = 1
RefEdit2.Text = ref(1)
RefEdit1.Text = ref(5)
RefEdit3.Text = ref(6)
RefEdit4.Text = ref(7)
If ref(7) = 1 Then
OptionButton2.Value = 1
Else
OptionButton1.Value = 1
End If
CommandButton3.Top = Me.Height + 1
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
Dim R1, R2, R3
If OptionButton2.Value = True Then
Call Hlkup
Exit Sub
End If
Dim d1 As New Dictionary
R1 = RefEdit1.Text '字典的目录
Call xinz(R1)
R2 = RefEdit2.Text '需要查找的目录
Call xinz(R2)
R3 = RefEdit3.Text '字典的内容
Call xinz(R3)
Arr = Range(R1)
If CheckBox2.Value = False Then
For i = 1 To UBound(Arr, 2)
For J = 1 To UBound(Arr)
Arr(J, i) = LCase(Arr(J, i))
Next J
Next i
End If
If R1 Like "*!*" Then
a = Split(R1, "!")(0)
If a Like ("*'*") Then a = Split(a, "'")(1)
Else
a = ActiveWorkbook.Name
End If
arr1 = Sheets(a).Cells(Range(R1).Row, Range(R3).Column).Resize(UBound(Arr), Range(R3).Columns.Count)
'建立字典
x = UBound(Arr, 2)
For i = 1 To UBound(Arr)
a = ""
For J = 1 To x
a = a & "♀" & Arr(i, J)
Next J
If Not d1.Exists(a) Then d1(a) = i
Next i
arr2 = Application.Intersect(Range(R2), Range(R2).Offset(Abs(CheckBox4 + 0), 0))
If CheckBox2.Value = False Then
For i = 1 To UBound(arr2, 2)
For J = 1 To UBound(arr2)
arr2(J, i) = LCase(arr2(J, i))
Next J
Next i
End If
ReDim arr3(1 To UBound(arr2), 1 To UBound(arr1, 2))
x = UBound(arr2, 2)
y = UBound(arr1, 2)
For i = 1 To UBound(arr2)
a = ""
For J = 1 To x
a = a & "♀" & arr2(i, J)
Next J
If d1.Exists(a) Then
For J = 1 To y
arr3(i, J) = arr1(d1(a), J)
Next J
End If
Next i
If RefEdit4.Text Like "*!*" Then
a = Split(RefEdit4.Text, "!")(0)
If a Like ("*'*") Then a = Split(a, "'")(1)
Else
a = ActiveWorkbook.Name
End If
Sheets(a).Cells(Range(R2).Row + Abs(CheckBox4 + 0), Range(RefEdit4.Text).Column).Resize(UBound(arr3), UBound(arr3, 2)) = arr3
If CheckBox1.Value = True Then
Set myc = New csh
Set myc.sht = ActiveSheet
ref(1) = RefEdit2.Text
ref(5) = RefEdit1.Text
ref(6) = RefEdit3.Text
ref(7) = RefEdit4.Text
ref(8) = 0
ref(9) = CheckBox2.Value
ref(2) = arr1
ref(3) = Range(RefEdit4.Text).Column
Set ref(4) = d1
End If
Me.hide
Exit Sub
ren:
MsgBox ("出错")
End Sub
Sub Hlkup()
On Error Resume Next
' Set d1 = CreateObject("Scripting.Dictionary")
Dim d1 As New Dictionary
R1 = RefEdit1.Text
Call xinz(R1)
R2 = RefEdit2.Text
Call xinz(R2)
R3 = RefEdit3.Text
Call xinz(R3)
Arr = Range(R1)
If CheckBox2.Value = False Then
For i = 1 To UBound(Arr, 2)
For J = 1 To UBound(Arr)
Arr(J, i) = LCase(Arr(J, i))
Next J
Next i
End If
If RefEdit1.Text Like "*!*" Then
a = Split(R1, "!")(0)
If a Like ("*'*") Then a = Split(a, "'")(1)
Else
a = ActiveWorkbook.Name
End If
arr1 = Sheets(a).Cells(Range(R3).Row, Range(R1).Column).Resize(Range(R3).Rows.Count, UBound(Arr, 2))
'建立字典
x = UBound(Arr)
For i = 1 To UBound(Arr, 2)
a = ""
For J = 1 To x
a = a & "♀" & Arr(J, i)
Next J
If Not d1.Exists(a) Then d1(a) = i
Next i
arr2 = Range(R2)
If CheckBox2.Value = False Then
For i = 1 To UBound(arr2, 2)
For J = 1 To UBound(arr2)
arr2(J, i) = LCase(arr2(J, i))
Next J
Next i
End If
ReDim arr3(1 To UBound(arr1), 1 To UBound(arr2, 2))
x = UBound(arr2)
y = UBound(arr1)
For i = 1 To UBound(arr2, 2)
a = ""
For J = 1 To x
a = a & "♀" & arr2(J, i)
Next J
If d1.Exists(a) Then
For J = 1 To y
arr3(J, i) = arr1(J, d1(a))
Next J
End If
Next i
If RefEdit4.Text Like "*!*" Then
a = Split(RefEdit4.Text, "!")(0)
If a Like ("*'*") Then a = Split(a, "'")(1)
Else
a = ActiveWorkbook.Name
End If
Sheets(a).Cells(Range(RefEdit4.Text).Row, Range(R2).Column).Resize(UBound(arr3), UBound(arr3, 2)) = arr3
If CheckBox1.Value = True Then
Set myc = New csh
Set myc.sht = ActiveSheet
ref(1) = RefEdit2.Text
ref(5) = RefEdit1.Text
ref(6) = RefEdit3.Text
ref(7) = RefEdit4.Text
ref(8) = 1
ref(9) = CheckBox2.Value
ref(2) = arr1
ref(3) = Range(RefEdit4.Text).Row
Set ref(4) = d1
End If
Me.hide
Exit Sub
ren:
MsgBox ("出错")
End Sub
Sub xinz(a) '确定选择区域的最佳区域，特别是选择整列时
Dim i As Long
Dim J As Long
Dim z As Long
Dim x
Dim y
Dim arr1, n
On Error GoTo ren
If a = "" Then Exit Sub
arr1 = Split(a, "$")
If UBound(arr1) = 0 Then Exit Sub
If arr1(1) Like "*:" Then
a = arr1(0)
If arr1(0) Like ("*'*") Then
arr1(0) = Split(a, "'")(1) & "!"
End If
If IsNumeric(Mid(arr1(1), 1, Len(arr1(1)) - 1)) Then
y = Sheets(Mid(arr1(0), 1, Len(arr1(0)) - 1)).UsedRange.Column
x = Sheets(Mid(arr1(0), 1, Len(arr1(0)) - 1)).UsedRange.Columns.Count + y - 1
y = Split(Cells(1, y).Address, "$")(1)
x = Split(Cells(1, x).Address, "$")(1)
z = Sheets(Mid(arr1(0), 1, Len(arr1(0)) - 1)).UsedRange.Rows.Count
n = arr1(2)
If z < n Then arr1(2) = z
a = a & "$" & y & "$" & arr1(1) & "$" & x & "$" & arr1(2)
Else
a = a & "$" & Mid(arr1(1), 1, Len(arr1(1)) - 1) & "$" & "1:$" & arr1(2) & "$" & Sheets(Mid(arr1(0), 1, Len(arr1(0)) - 1)).UsedRange.Rows.Count
End If
Else
If IsNumeric(arr1(2)) And UBound(arr1) = 2 Then Exit Sub
End If
Exit Sub
ren:
MsgBox ("出错")
End Sub
Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
On Error Resume Next
If KeyCode = 27 Then Unload Me
End Sub

复制代码

（3）模块代码

Public myc, ref(1 To 10) '此句代码为字典查询专用

复制代码

（4）类模块代码
1、csh

Public WithEvents sht As Worksheet
Private Sub sht_Change(ByVal Target As Range)
On Error GoTo ren
If ref(8) = 1 Then
x = Range(ref(1)).Row
y = Range(ref(1)).Column
xx = x - 1 + Range(ref(1)).Rows.Count
yy = y - 1 + Range(ref(1)).Columns.Count
x1 = Target.Row
y1 = Target.Column
If Not (x1 >= x And y1 >= y And x1 <= xx And y1 <= yy) Then Exit Sub
z = Target.Columns.Count
If z > 1 Then
arr2 = Range(Cells(x, y1), Cells(xx, y1 + z - 1))
If ref(9) = False Then
For i = 1 To UBound(arr2, 2)
For J = 1 To UBound(arr2)
arr2(J, i) = LCase(arr2(J, i))
Next J
Next i
End If
ReDim arr3(1 To UBound(ref(2)), 1 To z)
For J = 1 To z
a = ""
For i = 1 To xx - x + 1 '建立
a = a & "♀" & arr2(i, J)
Next i
If Not ref(4).Exists(a) Then
For i = 1 To UBound(ref(2))
arr3(i, J) = ""
Next i
Else
For i = 1 To UBound(ref(2))
arr3(i, J) = ref(2)(i, ref(4)(a))
Next i
End If
Next J
Cells(ref(3), y1).Resize(UBound(arr3), UBound(arr3, 2)) = arr3
Else
For i = x To xx '建立
If ref(9) = False Then
a = a & "♀" & LCase(Cells(i, y1).Value)
Else
a = a & "♀" & Cells(i, y1).Value
End If
Next i
If Not ref(4).Exists(a) Then
For i = 1 To UBound(ref(2), 2)
Cells(ref(3) - 1 + i, y1) = ""
Next i
Else
For i = 1 To UBound(ref(2))
Cells(ref(3) - 1 + i, y1) = ref(2)(i, ref(4)(a))
Next i
End If
End If
Else
x = Range(ref(1)).Row
y = Range(ref(1)).Column
xx = x - 1 + Range(ref(1)).Rows.Count
yy = y - 1 + Range(ref(1)).Columns.Count
x1 = Target.Row
y1 = Target.Column
If Not (x1 >= x And y1 >= y And x1 <= xx And y1 <= yy) Then Exit Sub
z = Target.Rows.Count
If z > 1 Then
arr2 = Range(Cells(x1, y), Cells(x1 + z - 1, yy))
If ref(9) = False Then
For i = 1 To UBound(arr2, 2)
For J = 1 To UBound(arr2)
arr2(J, i) = LCase(arr2(J, i))
Next J
Next i
End If
ReDim arr3(1 To z, 1 To UBound(ref(2), 2))
For J = 1 To z
a = ""
For i = 1 To yy - y + 1 '建立
a = a & "♀" & arr2(J, i)
Next i
If Not ref(4).Exists(a) Then
For i = 1 To UBound(ref(2), 2)
arr3(J, i) = ""
Next i
Else
For i = 1 To UBound(ref(2), 2)
arr3(J, i) = ref(2)(ref(4)(a), i)
Next i
End If
Next J
Cells(x1, ref(3)).Resize(UBound(arr3), UBound(arr3, 2)) = arr3
Else
For i = y To yy '建立
If ref(9) = False Then
a = a & "♀" & LCase(Cells(x1, i).Value)
Else
a = a & "♀" & Cells(x1, i).Value
End If
Next i
If Not ref(4).Exists(a) Then
For i = 1 To UBound(ref(2), 2)
Cells(x1, ref(3) - 1 + i) = ""
Next i
Else
For i = 1 To UBound(ref(2), 2)
Cells(x1, ref(3) - 1 + i) = ref(2)(ref(4)(a), i)
Next i
End If
End If
End If
Exit Sub
ren:
' Set myc.sht = Nothing
' Set myc = Nothing
' MsgBox ("出错")
End Sub

复制代码

2、css

Public WithEvents sht As Worksheet
Private Sub sht_Change(ByVal Target As Range)
On Error GoTo ren
Set yunx.sht = Nothing
Set yunx = Nothing
Set S = CreateObject("MSScriptControl.ScriptControl")
S.Language = "VBScript"
S.AddObject "ActiveWorkbook", ActiveWorkbook
S.AddObject "Application", Application
S.AddObject "Activesheet", ActiveSheet
S.AddObject "sheets", Sheets
S.AddObject "cells", Cells
S.addcode yunxi
S.Run "xi"
S.Reset
ren:
End Sub

复制代码

[ 本帖最后由 little-key 于 2009-11-22 21:33 编辑 ]

wenjiegufeng · 发表于 2009-11-22 21:20

我路过的。，来学习一下

little-key · 发表于 2009-11-22 21:23

希望大家多提一些修改或完善的意见，你们的需要，就是我们的需求，软件完善需要大伙的支持。

yvhgydn · 发表于 2009-11-22 21:40

主要用于哪些情况之下呢,
BS自已一下,在大师的面前,提出这样的问题,再汗一个

LangQueS · 发表于 2009-11-22 21:41

支持梁版！

bibisin · 发表于 2009-11-22 21:57

谢谢两位版主的分享,试用一下先

飞云楼主 · 发表于 2009-11-22 23:04

感觉很好，学习了。谢谢分享。

lb_bn · 发表于 2009-11-22 23:21

版主辛苦了。谢谢分享。

		自动登录	找回密码
密码			免费注册

[原创] 常用工具系列之一（自动查询）

评分