根据要求识别并提取组数据的问题

谢玉红

附件 根据要求识别提取组数据.rar (1.59 MB, 下载次数: 21)

2023-2-8 17:15 上传

点击文件名下载附件

谢谢老师！

盼盼198310

...................

gwjkkkkk

请楼主参考附件。。。

杨建营

请楼主参考。

杨建营

测试文件。

谢玉红

gwjkkkkk 发表于 2023-2-8 17:34
请楼主参考附件。。。

老师你好。谢谢帮助。经过试用，程序快捷准确。因考虑欠周到，以致结果需要人工标明序号。麻烦看看能否在返回的结果后面一列，增加序号。
如下图


谢谢了。

ykcbf1100

参与一下。

谢玉红

ykcbf1100 发表于 2023-2-9 13:02
参与一下。

谢谢老师关注。返回的结果中，D列增加条件序号。比如：04  04  是第一位的。标为 1        04   19是第二位好，标为2

gwjkkkkk

谢玉红 发表于 2023-2-9 11:32
老师你好。谢谢帮助。经过试用，程序快捷准确。因考虑欠周到，以致结果需要人工标明序号。麻烦看看能否在 ...

回家帮你弄一下。。。

fzxba

1. Sub test0() '据 8F要求 参与一下
   
2.   Dim ar, br() As Long, cr(), Dict As Object
   
3.   Dim i As Long, j As Integer, k As Integer, posRow As Long
   
4.   Dim rowSize() As Long, strKey As String
   
5.   
   
6.   Application.ScreenUpdating = False
   
7.   
   
8.   Sheet3.Activate
   
9.   Cells.Clear
   
10.   
    
11.   Set Dict = CreateObject("Scripting.Dictionary")
    
12.   ar = Sheet1.Range("A1").CurrentRegion.Resize(, 2)
    
13.   For i = 1 To UBound(ar)
    
14.     Dict.Add ar(i, 1) & "|" & ar(i, 2), i
    
15.   Next
    
16.   
    
17.   ar = Sheet2.Range("A1").CurrentRegion.Resize(, 3)
    
18.   ReDim br(1 To UBound(ar), 1 To UBound(ar, 2) + 1)
    
19.   ReDim cr(1 To Dict.Count)
    
20.   ReDim rowSize(1 To Dict.Count)
    
21.   
    
22.   For k = 1 To UBound(cr)
    
23.     cr(k) = br
    
24.   Next
    
25.   
    
26.   For i = 1 To UBound(ar)
    
27.     strKey = ar(i, 1) & "|" & ar(i, 2)
    
28.     If Dict.exists(strKey) Then
    
29.       k = Dict(strKey)
    
30.       rowSize(k) = rowSize(k) + 1
    
31.       For j = 1 To UBound(ar, 2)
    
32.         cr(k)(rowSize(k), j) = ar(i, j)
    
33.       Next
    
34.       cr(k)(rowSize(k), j) = k
    
35.     End If
    
36.   Next
    
37.   
    
38.   For k = 1 To UBound(cr)
    
39.     Range("A" & posRow + 1).Resize(rowSize(k), UBound(cr(k), 2)) = cr(k)
    
40.     posRow = posRow + rowSize(k)
    
41.   Next
    
42.   
    
43.   Set Dict = Nothing
    
44.   Application.ScreenUpdating = True
    
45.   Beep
    
46. End Sub

复制代码