根据条件。通Excel VBA批量数据提取，根据条件提取所有数据

ykcbf1100

参与一下。。。

ykcbf1100

用字典固定列号

1. Sub ykcbf()   '//2024.8.1
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Sheets("输出表格").UsedRange
   
6.     For j = 1 To UBound(arr, 2)
   
7.         s = arr(1, j)
   
8.         d(s) = j
   
9.     Next
   
10.     With Sheets("数据表")
    
11.         r = .Cells(Rows.Count, 1).End(3).Row
    
12.         c = .UsedRange.Columns.Count
    
13.         arr = .[a1].Resize(r, c)
    
14.     End With
    
15.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
16.     For i = 3 To UBound(arr)
    
17.         If arr(i, 13) = "已发货" Then
    
18.             m = m + 1
    
19.             brr(m, 1) = m
    
20.             For j = 2 To UBound(arr, 2)
    
21.                 s = arr(1, j)
    
22.                 If d.exists(s) Then
    
23.                     brr(m, d(s)) = arr(i, j)
    
24.                 End If
    
25.             Next
    
26.             
    
27.         End If
    
28.     Next
    
29.     With Sheets("输出表格")
    
30.         .UsedRange.Offset(2).Interior.ColorIndex = 0
    
31.         .UsedRange.Offset(2) = ""
    
32.         Set Rng = .Range("a3").Resize(m, d.Count)
    
33.         Rng.Value = brr
    
34.         Rng.Borders.LineStyle = 1
    
35.         Rng.Interior.ColorIndex = 6
    
36.     End With
    
37.     Set d = Nothing
    
38.     Application.ScreenUpdating = True
    
39.     MsgBox "OK！"
    
40. End Sub
    
41. 
    

复制代码