提取达标记录，并以此为标准，提取同类记录，谢谢 ykcbf1100和chxw68、Qs18老师！

ykcbf1100

原代码基础上改一下。

1. Sub test()
   
2.     Dim Arr2, ar, arr1()
   
3.     Dim myr%, i%, j%, m%
   
4.     Application.ScreenUpdating = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     With Sheet1
   
7.         ar = Range("a1:d45")
   
8.         ReDim arr1(1 To UBound(ar), 1 To 3)
   
9.         ReDim brr(1 To UBound(ar), 1 To 4)
   
10.         For i = 1 To UBound(ar)
    
11.             If Val(ar(i, 4)) = 0 And Val(ar(i, 2)) > 4.5 Then
    
12.                 m = m + 1
    
13.                 arr1(m, 1) = ar(i, 1)  '代码
    
14.                 arr1(m, 2) = ar(i, 3)  '行业
    
15.                 arr1(m, 3) = ar(i, 2) '涨幅%
    
16.                 d(CStr(arr1(m, 2))) = ""
    
17.             End If
    
18.         Next i
    
19.         For i = 1 To UBound(ar)
    
20.             s = ar(i, 3)
    
21.             If d.exists(s) Then
    
22.                 n = n + 1
    
23.                 For j = 1 To UBound(ar, 2)
    
24.                     brr(n, j) = ar(i, j)
    
25.                 Next
    
26.             End If
    
27.         Next i
    
28.         .Range("f2").Resize(m, 3) = arr1
    
29.         .Columns(21).NumberFormatLocal = "@"
    
30.         .Range("u2").Resize(n, 4) = brr
    
31.     End With
    
32.     Application.ScreenUpdating = True
    
33.     'Beep
    
34. End Sub
    

复制代码

杨建营

lhj323323 发表于 2024-9-10 15:08
谢谢老师！

你要按需提取，必备提取明细，要不然怎么提取你需要的

lhj323323

ykcbf1100 发表于 2024-9-10 15:46
原代码小改一下。
原代码把B列为--也提取出来，是因为B列有文本，用ar(i,2)>4.5判断方式不对，
应该如此 ...

测试成功了，多谢老师！

chxw68

下雨消磨时间。

lhj323323

chxw68 发表于 2024-9-10 16:37
下雨消磨时间。

谢谢chxw68老师！
鲜花明日奉上。

Qs18

lhj323323 发表于 2024-9-10 15:17
老师：
下图里
两组蓝框，都是基于红框而生成的

哦，是一次性做完还是分两个步骤

Qs18

1. Sub qs()
   
2. Dim arr, i, a
   
3. arr = Sheet1.Range("a1").CurrentRegion.Value
   
4. ReDim crr(1 To UBound(arr), 1 To 3)
   
5. For i = 2 To UBound(arr) '第一步提取D列为0，且B列>4.5的记录，并导入到F列
   
6.    s = Val(arr(i, 2)): s2 = Val(arr(i, 4))
   
7.     If s > 4.5 And s2 = 0 Then
   
8.         n = n + 1
   
9.         crr(n, 1) = arr(i, 1): crr(n, 2) = arr(i, 3): crr(n, 3) = arr(i, 2)
   
10.     End If
    
11. Next
    
12. Sheet1.Range("j2").Resize(n, 3) = crr
    
13. '第二步，再从A-D列提取C列是这3个（专用机械、医疗保键、化学制药）的记录，并导入到U列
    
14. ReDim brr(1 To UBound(arr), 1 To 4)
    
15. For i = 1 To n
    
16.     For y = 2 To UBound(arr)
    
17.         s = arr(y, 3)
    
18.         If crr(i, 2) = s Then
    
19.             m = m + 1
    
20.             For x = 1 To 4
    
21.                 brr(m, x) = arr(y, x)
    
22.             Next
    
23.         End If
    
24.     Next
    
25. Next
    
26. Sheet1.Range("u19").Resize(m, 4) = brr '改成需要的位置
    
27. End Sub

复制代码

Qs18

试试。。。。。。。。

Qs18

试试。。。。。。。。

lhj323323

Qs18 发表于 2024-9-11 21:19
哦，是一次性做完还是分两个步骤

是一次性。