怎么用VBA自动筛查excel数据表

xiangye30520

如附件 表（sheet1 ）品目列   想把表（需求品目）A列的数据自动筛查出来并另存为一张表格，感谢。

tanglf188

3190496160

Sub 筛选()
Application.ScreenUpdating = False
Dim ar As Variant, cr As Variant
Dim i As Long, r As Long
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("需求品目")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:a" & r)
End With
For i = 1 To UBound(ar)
    If ar(i, 1) <> "" Then
        d(ar(i, 1)) = ""
    End If
Next i
With Sheets("Sheet1")
    cr = .[a1].CurrentRegion
End With
ReDim br(1 To UBound(cr), 1 To UBound(cr, 2))
For i = 2 To UBound(cr)
    If cr(i, 3) <> "" Then
        If d.exists(cr(i, 3)) Then
            n = n + 1
            For j = 1 To UBound(cr, 2)
                br(n, j) = cr(i, j)
            Next j
        End If
    End If
Next i
If n = "" Then MsgBox "没有符合条件的数据！": End
With Sheets("筛选结果")
    .[a1].CurrentRegion = Empty
    .[a1].Resize(1, UBound(cr, 2)) = cr
    .[a2].Resize(n, UBound(br, 2)) = br
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

test2.rar (44.09 KB, 下载次数: 4)

2024-6-4 14:32 上传

点击文件名下载附件

shiruiqiang

union

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.6.4
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("需求品目")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         arr = .[a1].Resize(r, 1)
   
7.     End With
   
8.     For i = 1 To UBound(arr)
   
9.         s = Trim(arr(i, 1))
   
10.         d(s) = ""
    
11.     Next
    
12.     With Sheets("Sheet1")
    
13.         r = .Cells(Rows.Count, 1).End(3).Row
    
14.         c = .UsedRange.Columns.Count
    
15.         arr = .[a1].Resize(r, c)
    
16.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
17.         For i = 2 To UBound(arr)
    
18.             s = arr(i, 3)
    
19.             If d.exists(s) Then
    
20.                 m = m + 1
    
21.                 For j = 1 To UBound(arr, 2)
    
22.                     brr(m, j) = arr(i, j)
    
23.                 Next
    
24.             End If
    
25.         Next
    
26.     End With
    
27.     With Sheets("结果表")
    
28.         .UsedRange.Offset(1).Clear
    
29.         .[a1].Resize(1, c).Interior.Color = 49407
    
30.         With .[a2].Resize(m, c)
    
31.             .Value = brr
    
32.             .Borders.LineStyle = 1
    
33.             .HorizontalAlignment = xlCenter  '//列居中
    
34.             .VerticalAlignment = xlCenter
    
35.         End With
    
36.     End With
    
37.     Set d = Nothing
    
38.     Application.ScreenUpdating = True
    
39.     MsgBox "OK！"
    
40. End Sub
    

复制代码