AI整不出来这个代码啦，上这里求助试试

chxw68

修改好了。

zxsea_7426

Ericcccccc 发表于 2023-4-11 11:14
这个代码真香，有个小问题能否修改下？
需求4没有颜色那部分数据堆叠到最后时，代码按行遍历输出，比如 ...

我初始写的就是按列的，后来发现与你给的结果不一样，看半天才发现匹配外是按行的,后来才改成这样.

1. Sub test()
   
2.     With Sheet1
   
3.         ar = .UsedRange
   
4.         r = .Cells(Rows.Count, "A").End(3).Row
   
5.         c = .UsedRange.Columns.Count
   
6.         ReDim arr(1 To 7, 1 To 1)
   
7.         ReDim brr(1 To 7, 1 To 1)
   
8.         For i = 2 To r Step 6
   
9.             temp = .Range(.Cells(i, "D"), .Cells(i + 5, "D"))
   
10.             nn = WorksheetFunction.Small(.Range(.Cells(i, "D"), .Cells(i + 5, "D")), 1)
    
11.             For j = 7 To 7 + nn - 1
    
12.                 For i1 = i To i + 5
    
13.                     If i1 > r Then Exit For
    
14.                     If ar(i1, j) <> "" Then
    
15.                         n = n + 1
    
16.                         ReDim Preserve arr(1 To 7, 1 To n)
    
17.                         For j_ = 1 To 6
    
18.                             arr(j_, n) = ar(i1, j_)
    
19.                         Next j_
    
20.                         arr(7, n) = ar(i1, j)
    
21.                     End If
    
22.                 Next i1
    
23.             Next j
    
24.             For j = 7 + nn To c
    
25.                 For i1 = i To i + 5
    
26.                     If i1 > r Then Exit For
    
27.                         If ar(i1, j) <> "" Then
    
28.                             m = m + 1
    
29.                             ReDim Preserve brr(1 To 7, 1 To m)
    
30.                             For j_ = 1 To 6
    
31.                                 brr(j_, m) = ar(i1, j_)
    
32.                             Next j_
    
33.                             brr(7, m) = ar(i1, j)
    
34.                         End If
    
35.                 Next i1
    
36.             Next j
    
37.         Next i
    
38.     End With
    
39.     With Sheet3
    
40.         .[a2].Resize(n, 7) = Application.Transpose(arr)     '以最小值匹配的数据
    
41.         .[a2].Offset(n, 0).Resize(m, 7) = Application.Transpose(brr)   '根据匹配数据后未进行匹配的的数据
    
42.     End With
    
43. End Sub

复制代码

grf1973

挺好玩的，凑个数。正表之外的也是按先列后行提取。

1. Sub test()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set d1 = CreateObject("scripting.dictionary")
   
4.     With Worksheets("sheet1")
   
5.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
7.         arr = .Range("a1").Resize(r, c)
   
8.     End With
   
9.     ReDim brr(1 To 1000, 1 To 7)
   
10.     ReDim crr(1 To 1000, 1 To 7)
    
11.     For i = 2 To UBound(arr)
    
12.         x = arr(i, 5)
    
13.         If Not d.exists(x) Then d(x) = arr(i, 4) Else d(x) = Application.Min(d(x), arr(i, 4))   '取最小数量
    
14.         For j = 7 To UBound(arr, 2)   'd1(组 & 列)=对应行的集合
    
15.             If arr(i, j) <> "" Then d1(x & j) = d1(x & j) & "," & i
    
16.         Next
    
17.     Next
    
18.             
    
19.     For Each x In d.keys   '每组
    
20.         jj = d(x) + 6   '最小数量对应的最小列
    
21.         For j = 7 To UBound(arr, 2)
    
22.             t = d1(x & j)   'd1(组 & 列)=对应行的集合
    
23.             If Len(t) Then
    
24.                 trr = Split(Mid(t, 2), ",")
    
25.                 If j <= jj Then   '<=最小列的，提取到一张表
    
26.                     For Each i In trr
    
27.                         m = m + 1
    
28.                         For k = 1 To 6: brr(m, k) = arr(i, k): Next
    
29.                         brr(m, 7) = arr(i, j)
    
30.                     Next
    
31.                 Else    '>最小列的，提取到另一张表
    
32.                     For Each i In trr
    
33.                         n = n + 1
    
34.                         For k = 1 To 6: crr(n, k) = arr(i, k): Next
    
35.                         crr(n, 7) = arr(i, j)
    
36.                     Next
    
37.                 End If
    
38.             End If
    
39.         
    
40.         Next
    
41.     Next
    
42.     With Sheets("最终")   '按序输出
    
43.         If m > 0 Then .[I2].Resize(m, 7) = brr
    
44.         If n > 0 Then .Cells(m + 2, "I").Resize(n, 7) = crr
    
45.     End With
    
46. End Sub

复制代码