用宏给excel的下拉菜单追加模糊查询功能（原创）

trowy

例如，要在E9录入代码，有两种方式，可直接将代码录入E9;另一种是在C9录入查询文字，例如“维塔柠檬”，按Ctrl+X快捷键执行宏“下拉菜单查询”，在D9列便会自动生成包含“维塔柠檬”文字的所有商品信息，点击下拉菜单录入。

注意：
1.每次录入时活动光标一定要放在录入信息的正下方的单元格，这是由于宏使用了相对引用的原因，例如，在C9录入信息，光标必须放在C10位置，再按Ctrl+X执行模糊查找，在B9录入信息，光标必须放在C10位置，再按Ctrl+X执行模糊查找，在A9录入信息，光标必须放在C10位置，再按Ctrl+X执行模糊查找，不管是A9、B9、C9，活动光标都得定位在C10后执行宏。
2.执行宏会自动删除录入查询数据以上三列的数据，如，C9录入，C10放光标后执行宏，会自动清除A1:C8区域的数据。
3.每次执行查询时，必须确保非当前表如sheet4、sheet5、sheet6的ABC三列数据为空，Sheet1的查询数据单元格以上三列数据为空，例如C9录入“维塔柠檬”，必须确保Sheet1的A1:C8的数据为空，并且sheet4、sheet5、sheet6的ABC三列数据为空。
4.表“过渡”，sheet1、sheet2三个表为过程数据表，不可删除。



宏“下拉菜单查询”的代码如下：


Sub 下拉菜单查询()
'
' 下拉菜单查询 Macro
' 宏由 微软中国 录制，时间: 2011-1-15
'

    a = Application.ActiveSheet.Name
    b = Application.Selection.Address
    Range("D1:H1").Select
    Selection.Copy
    Range(b).Select
    Selection.Offset(-1, 1).Select
    ActiveSheet.Paste
    Range(b).Select
    Range("A1", ActiveCell.Offset(-2, 0)).Select
    Selection.ClearContents
    Sheets("Sheet2").Select
    Range("A1").CurrentRegion.Select
    Selection.ClearContents
    Sheets("Sheet1").Select
    Rows("1:1").Select
    Selection.AutoFilter Field:=1, Criteria1:=Range("G1").Value, Operator:=xlAnd
    Range("A1").CurrentRegion.Select
    Selection.Copy
    Sheets("Sheet2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    If Range("A1").Value = Range("A2").Value Then
    Range("A1").CurrentRegion.Select
    Selection.ClearContents
    Sheets("Sheet1").Select
    Rows("1:1").Select
    Selection.AutoFilter Field:=1, Criteria1:=Range("H1").Value, Operator:=xlAnd
    Range("A1").CurrentRegion.Select
    Selection.Copy
    Sheets("Sheet2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ElseIf Range("A1").Value <> Range("A2").Value Then
    End If
    If Range("A1").Value = Range("A2").Value Then
    Range("A1").CurrentRegion.Select
    Selection.ClearContents
    Sheets("Sheet1").Select
    Rows("1:1").Select
    Selection.AutoFilter Field:=1, Criteria1:=Range("I1").Value, Operator:=xlAnd
    Range("A1").CurrentRegion.Select
    Selection.Copy
    Sheets("Sheet2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ElseIf Range("A1").Value <> Range("A2").Value Then
    End If
    If Range("A1").Value = Range("A2").Value Then
    Range("A1").CurrentRegion.Select
    Selection.ClearContents
    Sheets("Sheet1").Select
    Rows("1:1").Select
    Selection.AutoFilter Field:=1, Criteria1:=Range("J1").Value, Operator:=xlAnd
    Range("A1").CurrentRegion.Select
    Selection.Copy
    Sheets("Sheet2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ElseIf Range("A1").Value <> Range("A2").Value Then
    End If
    If Range("A1").Value = Range("A2").Value Then
    Range("A1").CurrentRegion.Select
    Selection.ClearContents
    Sheets("Sheet1").Select
    Rows("1:1").Select
    Selection.AutoFilter Field:=1, Criteria1:=Range("K1").Value, Operator:=xlAnd
    Range("A1").CurrentRegion.Select
    Selection.Copy
    Sheets("Sheet2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ElseIf Range("A1").Value <> Range("A2").Value Then
    End If
    If Range("A1").Value = Range("A2").Value Then
    Range("A1").CurrentRegion.Select
    Selection.ClearContents
    Sheets("Sheet1").Select
    Rows("1:1").Select
    Selection.AutoFilter Field:=1, Criteria1:=Range("L1").Value, Operator:=xlAnd
    Range("A1").CurrentRegion.Select
    Selection.Copy
    Sheets("Sheet2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ElseIf Range("A1").Value <> Range("A2").Value Then
    End If
    Sheets(a).Select
    Range(b).Select
    Selection.Offset(-1, 1).Select
   
   

   
End Sub

taitai9616

这个貌似太复杂了些

JLF2003

可以借鉴。谢谢楼主作品。

ccschina

是好复杂，但很不错了，能想出这些来．支持一个

lantu

很不错啊！

yangkeyuan

谢谢楼主的好东西！

幻砾

谢谢 下载学习

懒猫杜

暂时看不懂 不过没关系  我会赶上来的
加油

非常公民

学习、借鉴、学以至用