表格数据提取VBa实现

97115038a

表格1是原始数据

表格2是需要重原始数据提取的数据
表格3是提取的结果，
请问怎样快速的提取出，3w数据，用筛选也是卡的一批
提取是整行,，希望哥哥们出手相助，同时祝贺哥哥们新年快乐
附件不方便上传，忘见谅

97115038a

3190496160 发表于 2023-1-22 09:25
看了楼主的几个帖子，都是没有附件的，呵呵

提取关键字（王）过程中只提取到第三行，第一行和第二行没有提取到

97115038a

不要沉底哦，谢谢

yxp

详见 VLOOKUP 函数

yxp

详见 VLOOKUP 函数，不需要第三个表格

psxk3535

好好学习

tmplinshi

1. Sub SQL提取数据()
   
2. 
   
3.     Const sheetSrc$ = "1"
   
4.     Const sheetKey$ = "2"
   
5.     Const sheetOut$ = "3"
   
6.    
   
7.     Dim values$, sql$
   
8.    
   
9.     values = GetKeywordsFrom(sheetKey)
   
10.     sql = "select * from [" & sheetSrc & "$] where F1 IN " & values
    
11.    
    
12.     Sheets(sheetOut).Cells.Clear
    
13.     SqlToRange sql, Sheets(sheetOut).Cells(1)
    
14.    
    
15. End Sub
    
16. 
    
17. Function GetKeywordsFrom(sheetName As String)
    
18. 
    
19.     Dim rng As Range, arr1, values$, sql$
    
20.    
    
21.     Set rng = Sheets(sheetName).UsedRange.Columns("A")
    
22.     arr1 = WorksheetFunction.Transpose(rng.Value)
    
23.     GetKeywordsFrom = "('" & Join(arr1, "','") & "')"
    
24.    
    
25. End Function
    
26. 
    
27. Sub SqlToRange(sql As String, rng As Range)
    
28.    
    
29.     Dim conn As Object
    
30.     Set conn = CreateObject("ADODB.Connection")
    
31. 
    
32.     With conn
    
33.        .Provider = "Microsoft.ACE.OLEDB.12.0"
    
34.        .Properties("Data Source") = ThisWorkbook.FullName
    
35.        .Properties("Extended Properties") = "Excel 12.0 xml; HDR=No; IMEX=1"
    
36.     End With
    
37. 
    
38.     conn.Open
    
39.     rng.CopyFromRecordset conn.Execute(sql)
    
40.     conn.Close
    
41.    
    
42. End Sub
    

复制代码

3190496160

Sub 取数()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Dim arr()
With Sheets("2")
    ar = .[a1].CurrentRegion
End With
With Sheets("1")
    br = .[a1].CurrentRegion
End With
ReDim arr(1 To UBound(br), 1 To UBound(br, 2))
For i = 1 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        d(Trim(ar(i, 1))) = ""
    End If
Next i
For i = 1 To UBound(br)
    If d.exists(Trim(br(i, 1))) Then
        n = n + 1
        For j = 1 To UBound(br, 2)
            arr(n, j) = br(i, j)
        Next j
    End If
Next i
If n = "" Then MsgBox "没有需要提取的数据!": End
With Sheets("3")
    .[a1].CurrentRegion.Borders.LineStyle = 0
    .[a1].CurrentRegion = Empty
    .[a1].Resize(n, UBound(arr, 2)) = arr
    .[a1].Resize(n, UBound(arr, 2)) = arr
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

提取数据.rar (18.51 KB, 下载次数: 19)

2023-1-22 09:22 上传

点击文件名下载附件

3190496160

看了楼主的几个帖子，都是没有附件的，呵呵