想将一张表格中某几列均不为0的数据提取到另一张表中

fifi0703

想将一张表格中某几列均不为0的数据提取到另一张表中


不需要整行数据，只要求这几列

以为简单，小白自己搞了一个，可就是提取不到，
求大神指教，谢谢！
筛选提取.zip (485.55 KB, 下载次数: 13)

2024-1-19 10:30 上传

点击文件名下载附件

2Denny19

你M列不是全为0嘛。

洋务德雷

用SQL 做的。有数据更新，只要右键点击结果表，刷新即可。
以目前统计表得数据看，那几列不为0得数据，现在查询的是没有数据。

fifi0703

2Denny19 发表于 2024-1-19 10:40
你M列不是全为0嘛。

谢谢提醒，我不应该用 and 应该用 or

fifi0703

筛选提取.zip (499.23 KB, 下载次数: 4)

2024-1-19 11:12 上传

点击文件名下载附件

改了一下，有数据了，可是中间有空行怎么办？

fifi0703

洋务德雷 发表于 2024-1-19 10:43
用SQL 做的。有数据更新，只要右键点击结果表，刷新即可。
以目前统计表得数据看，那几列不为0得数据，现 ...

好高级，打开了我的新世界，一个未知的领域

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.1.19
   
2.     Dim arr, d, brr
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("数据提取表")
   
6.         For j = 1 To 8
   
7.             s = .Cells(1, j)
   
8.             d(s) = j
   
9.         Next
   
10.     End With
    
11.     ReDim brr(1 To 10000, 1 To 8)
    
12.     With Sheets("统计表")
    
13.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
14.         arr = .[a1].Resize(r, 17)
    
15.         For i = 2 To UBound(arr)
    
16.             m = m + 1
    
17.             For j = 1 To UBound(arr, 2)
    
18.                 s = arr(1, j)
    
19.                 If d.Exists(s) Then
    
20.                     brr(m, d(s)) = arr(i, j)
    
21.                 End If
    
22.             Next
    
23.         Next
    
24.     End With
    
25.     With Sheets("数据提取表")
    
26.         .UsedRange.Offset(1).Clear
    
27.         With .[a2].Resize(m, 8)
    
28.             .Value = brr
    
29.             .Borders.LineStyle = 1
    
30.             .HorizontalAlignment = xlCenter
    
31.             .VerticalAlignment = xlCenter
    
32.         End With
    
33.     End With
    
34.     Set d = Nothing
    
35.     Application.ScreenUpdating = True
    
36.     MsgBox "OK！"
    
37. End Sub
    

复制代码

ykcbf1100

用字典做一个，附件供参考。。。

fifi0703

ykcbf1100 发表于 2024-1-19 11:21
用字典做一个，附件供参考。。。

大师出手，果然不凡

yynrzwh

筛选提取.rar (623.7 KB, 下载次数: 3)

2024-1-19 16:23 上传

点击文件名下载附件