麻烦各位VBA的老师给想想办法，搞了一天了

洋务德雷

做一个sql+vba的

lkqsmxw

Sub 自主信息查询()
    Dim D, SHT As Worksheet, SHX As Worksheet, Awk As Workbook, Wb As Workbook, SH As Worksheet
    Dim ARR, BRR, CRR, ROWX, wjname, wjmm, liebiaoshi, LBS
    Dim I, J, M, N, K, S, X, Z, Y, Ya, Yb, Xa, Xb, Za, Zb, Q
    Dim ColA As Integer, RgA As Integer, ColB As Integer, RgB As Integer, ColXA As Integer, ColXB As Integer
    Dim 查找值, 查找值集, cansu, sjqshs, cxlls
    Dim MYREG As Object
    Dim T
    '''T = Timer
    Dim rng03&, rng07&, col03&, col07&, rngRX&, colCY&
    Application.ScreenUpdating = False                         '//关闭屏幕刷新
    Application.DisplayAlerts = False                          '//关闭系统提示
    'Application.Calculation = xlManual
    On Error Resume Next                                       '// 发生错误，自动执行下一句，就是忽略错误
    Set D = CreateObject("Scripting.Dictionary")               '创建一个字典对象
    Set MYREG = CreateObject("vbscript.regexp")
    With MYREG                                                 ''''设置字符替换
        .Global = True: .IgnoreCase = True: .Pattern = "[，；：;:]"    '''"[^A-Z ]"
    End With
    Set Awk = ActiveWorkbook
    Awk.Activate
    Set SHT = Awk.ActiveSheet
    '''EXCEL2003:65536行,256列[IV]; EXCEL2007:1048576行,16384列[XFD]
    If Application.Version <= 11 Then                          '2003或以下
    rng03 = 65536: col03 = 256
    rngRX = rng03: colCY = col03
Else                                                       '2007或以上
    rng07 = 1048576: col07 = 16384
    rngRX = rng07: colCY = col07
End If
cansu = Application.InputBox("请输入必要参数！" & Chr(10) & "数据起始行数和查询列列数，用[,]分隔开。", Type:=3)    '''参数8：type为 0 返回文本，type为1返回数字， type为2返回公式 ，4逻辑值，8单元格引用，16错误值，64数值数组。type不指定时，系统根据输入智能判断数据类型。
If cansu = 0 Or cansu = "" Then Exit Sub Else If UBound(Split(Replace(Replace(MYREG.Replace(Replace(cansu, "=", ""), ","), " ", ""), ",,", ","), ",")) <> "" Then _
    cansu = Replace(Replace(MYREG.Replace(Replace(cansu, "=", ""), ","), " ", ""), ",,", ",")
sjqshs = Val(Split(cansu, ",")(0))
cxlls = Val(Split(cansu, ",")(1))
If sjqshs = 0 Or sjqshs = "" Then MsgBox "输入的参数不全，请重新输入！": Exit Sub Else sjqshs = sjqshs
If cxlls = 0 Or cxlls = "" Then MsgBox "输入的参数不全，请重新输入！": Exit Sub Else cxlls = cxlls
查找值集 = Application.InputBox("请输入欲查询的关键词！" & Chr(10) & "可一项也可多项，用[,]分隔开。", Type:=3)    '''参数8：type为 0 返回文本，type为1返回数字， type为2返回公式 ，4逻辑值，8单元格引用，16错误值，64数值数组。type不指定时，系统根据输入智能判断数据类型。
If 查找值集 = 0 Or 查找值集 = "" Then Exit Sub Else If UBound(Split(Replace(Replace(MYREG.Replace(Replace(查找值集, "=", ""), ","), " ", ""), ",,", ","), ",")) <> "" Then _
    查找值集 = Replace(Replace(MYREG.Replace(Replace(查找值集, "=", ""), ","), " ", ""), ",,", ",")    '''Split()
If 查找值集 = 0 Or 查找值集 = "" Then MsgBox "没发现查询关键词，请重新输入！": Exit Sub Else 查找值集 = 查找值集
UserForm12.Hide
'ROWX = Sht.Cells(1, ColA).CurrentRegion.Rows.Count         '''.CurrentRegion当前区域'''.UsedRange已经使用的区域'''.Columns
'arr = Sht.Cells(RgA, ColA).Resize(ROWX - RgA + 1, ColXA)
T = Timer
With Awk
    For Each SH In .Sheets
        ARR = SH.UsedRange
        ReDim BRR(1 To UBound(ARR), 1 To UBound(ARR, 2) + 1)
        N = 0
        For I = sjqshs To UBound(ARR)
            For K = LBound(Split(查找值集, ",")) To UBound(Split(查找值集, ","))
                查找值 = Split(查找值集, ",")(K)
                If ARR(I, cxlls) Like "*" & 查找值 & "*" = True Then
                    '''If Not D.Exists(arr(i, cxlls)) Then
                    N = N + 1
                    '''D(arr(i, cxlls)) = N
                    For J = 1 To UBound(ARR, 2)
                        '''brr(D(arr(i, cxlls)), J) = arr(i, J)
                        BRR(N, J) = ARR(I, J)
                    Next
                    '''brr(D(arr(i, cxlls)), UBound(brr, 2)) = 查找值
                    BRR(N, UBound(BRR, 2)) = 查找值
                    '''Else
                    '''If brr(D(arr(i, cxlls)), UBound(brr, 2)) Like "*" & 查找值 & "*" = False Then brr(D(arr(i, cxlls)), UBound(brr, 2)) = brr(D(arr(i, cxlls)), UBound(brr, 2)) & "," & 查找值
                    '''End If
                End If
            Next
        Next
        If ActiveWorkbook.Sheets("查询结果_" & SH.Name).Select <> "" Then ActiveWorkbook.Sheets("查询结果_" & SH.Name).Delete
        If N > 0 Then
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = "查询结果_" & SH.Name
            Set SHX = Sheets(ActiveSheet.Name)
            SHX.Activate
            SHX.Cells(sjqshs, 1).Resize(N + 1, UBound(BRR, 2)).NumberFormat = "@"
            SHX.Cells(sjqshs, 1).Resize(N + 1, UBound(BRR, 2)) = BRR
            ActiveWindow.DisplayZeros = False
            SHX.Cells(sjqshs - 1, 1).Resize(N + 1, UBound(BRR, 2)).Borders.LineStyle = xlContinuous
            SHX.Cells(1, 1).Resize(sjqshs - 1, UBound(BRR, 2)).Font.Bold = True
            SH.Cells(1, 1).Resize(sjqshs - 1, UBound(BRR, 2) - 1).Copy SHX.Cells(1, 1)
            SHX.Cells(sjqshs - 1, UBound(BRR, 2)) = "查询关键词"
            SHX.Cells(sjqshs - 1, UBound(BRR, 2)).Resize(N + 1, 1).Font.ColorIndex = 3
        End If
        Erase ARR
        Erase BRR
        SH = Nothing
    Next
End With
MsgBox "查询完毕!" & vbCrLf & "用时：" & Format(Timer - T, "#0.0000") & " 秒", , "友情提示!!"    '//提示所用时间
Set MYREG = Nothing
Set D = Nothing
Application.ScreenUpdating = True                          '//恢复屏幕刷新
Application.DisplayAlerts = True                           '//恢复系统提示
Application.Calculation = xlAutomatic
End Sub

lkqsmxw

kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk