[已解决]用代码根据要求提取数据的问题

dfshm

附件 根据要求提取行数据附件.rar (573.83 KB, 下载次数: 22)

2017-6-17 23:41 上传

点击文件名下载附件
谢谢老师!

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-6-19 13:07

1. Sub aaa()
   
2. Dim arr, brr, crr, i&, j&, k&, l&, r&, d As Object, n&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheets(1).[a1:f1]
   
5. For i = 1 To UBound(arr, 2)
   
6.   d(arr(1, i)) = ""
   
7. Next i
   
8. brr = Sheets(2).UsedRange
   
9. ReDim crr(1 To UBound(brr), 1 To UBound(brr, 2))
   
10. For j = 1 To UBound(arr, 2)
    
11.   For i = 1 To UBound(brr)
    
12.     If arr(1, j) = brr(i, 2) Then
    
13.       For k = 2 To 7
    
14.         If d.exists(brr(i, k)) Then n = n + 1
    
15.       Next k
    
16.       If n = 4 Then
    
17.         r = r + 1
    
18.         For l = 1 To UBound(brr, 2)
    
19.           crr(r, l) = brr(i, l)
    
20.         Next l
    
21.       End If
    
22.       n = 0
    
23.     End If
    
24.   Next i
    
25.   r = r + 1
    
26. Next j
    
27. Sheets(3).Cells.Clear
    
28. Sheets(3).[a1].Resize(r, UBound(crr, 2)) = crr
    
29. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

1. Sub aaa()
   
2. Dim arr, brr, crr, i&, j&, k&, l&, r&, d As Object, n&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheets(1).[a1:f1]
   
5. For i = 1 To UBound(arr, 2)
   
6.   d(arr(1, i)) = ""
   
7. Next i
   
8. brr = Sheets(2).UsedRange
   
9. ReDim crr(1 To UBound(brr), 1 To UBound(brr, 2))
   
10. For j = 1 To UBound(arr, 2)
    
11.   For i = 1 To UBound(brr)
    
12.     If arr(1, j) = brr(i, 2) Then
    
13.       For k = 2 To 7
    
14.         If d.exists(brr(i, k)) Then n = n + 1
    
15.       Next k
    
16.       If n = 4 Then
    
17.         r = r + 1
    
18.         For l = 1 To UBound(brr, 2)
    
19.           crr(r, l) = brr(i, l)
    
20.         Next l
    
21.       End If
    
22.       n = 0
    
23.     End If
    
24.   Next i
    
25.   r = r + 1
    
26. Next j
    
27. Sheets(3).Cells.Clear
    
28. Sheets(3).[a1].Resize(r, UBound(crr, 2)) = crr
    
29. End Sub

复制代码

dfshm

大灰狼1976 发表于 2017-6-19 13:07

老师你好,能否把结果按题意标色啊?谢谢了.

大灰狼1976

用VBA标色的话，原来的数组代码就要改写成单元格操作了，效率很低，数据量大时更明显，
不如用条件格式来达成，附件是我设置的条件格式，你自己看下吧。