如何用VBA实现根据关键字，筛选包含这个关键字的行，并统计出现次数？

cjc209

此用户被禁言 发表于 2017-2-10 15:38
参考一下是不是这样的效果？启用宏
修改一下。。。

你的有一点不好 就是要是没有出现 你把原来条件就删除了
我给你修改了一下
Sub 包含筛选数据统计出现次数()
    Dim arr
    Set d = CreateObject("scripting.dictionary")
    tim = Timer
    Dim crr(1 To 55000, 1 To 6)
    With Sheets("数据结果")
        irow = .Cells(.Rows.Count, 10).End(xlUp).Row
        arr = .Range("J2:J" & irow) '要查找的值列表区
        If Not IsArray(arr) Then
            ReDim arr(1 To 1, 1 To 1)
            arr(1, 1) = .Range("J2:J" & irow)
        End If
    End With
    With Sheets("数据源")
        imax = .Cells(.Rows.Count, 1).End(xlUp).Row
        brr = .Range("A2:F" & imax) '源数据
    End With
    For k = 1 To UBound(arr)
        d(arr(k, 1) & "") = 0 '查找关键字进入字典
        For n = 1 To UBound(brr)
            If InStr(brr(n, 1), arr(k, 1)) > 0 Then 'brr(n, 1)在源数据第一列里去找
                d(arr(k, 1)) = d(arr(k, 1)) + 1 '出现次数计数
                m = m + 1 '结果行号
                crr(m, 1) = brr(n, 1) '以下是需要返回的值
                crr(m, 2) = brr(n, 2)
                crr(m, 3) = brr(n, 3)
                crr(m, 4) = brr(n, 4)
                crr(m, 5) = brr(n, 5)
                crr(m, 6) = brr(n, 6)
            End If
        Next
    Next
    Sheets("数据结果").Range("A2:F45000") = ""
    Sheets("数据结果").Range("k2:K" & irow) = ""
    Sheets("数据结果").Range("A2").Resize(m, 6) = crr
    Sheets("数据结果").Range("K2").Resize(d.Count, 1) = Application.Transpose(d.items)
    MsgBox "执行完毕!_用时:  " & Format(Timer - tim, "0.00") & "  秒"
End Sub
这样就不会删除 结果统计为0

cjc209

myhyday 发表于 2021-12-8 14:14
麻烦请教一下大佬，您这份程序中的关键词筛选是“或”的关系，也就是说假如有ABC三个关键词，只要对象中 ...

肯定可以 变一下条件就可以了

wang-way

1. Sub SQL_QUERY()
   
2.     '实例化对象
   
3.     Set Wb = Application.ThisWorkbook
   
4.     DataPath = Wb.FullName
   
5.     Set DataSht = Wb.Worksheets("数据源")
   
6.     Set Sht = Wb.Worksheets("数据结果")
   
7.     Dim DATA_ENGINE As String
   
8.     Select Case Application.Version * 1
   
9.     Case Is <= 11
   
10.         DATA_ENGINE = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=no;IMEX=2';Data Source="
    
11.     Case Is >= 12
    
12.         DATA_ENGINE = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=no;IMEX=2'; Data Source= "
    
13.     End Select
    
14. 
    
15.     Set CNN = CreateObject("ADODB.Connection")
    
16.     Set RS = CreateObject("ADODB.RecordSet")
    
17.     CNN.Open DATA_ENGINE & DataPath
    
18.     With Sht
    
19.         .Cells.Clear
    
20.         Key = "白板"
    
21.         EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
    
22.         Set Rng = .Range("A1")
    
23.         Sql = "SELECT * FROM [" & DataSht.Name & "$A2:F] WHERE f1 like '%" & Key & "%'"
    
24.         Debug.Print Sql
    
25.         Set RS = CNN.Execute(Sql)
    
26.         Rng.CopyFromRecordset RS
    
27. 
    
28.     End With
    
29.     RS.Close
    
30.     CNN.Close
    
31. End Sub
    
32. 
    

复制代码

cnyfk

wang-way 发表于 2022-4-29 13:03

大神，“where f1……” 这个sql语句中的"f1"是啥意思？