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

Ericcccccc

1.每6行（不足6行按实际行数），根据D列获得每组的最小值
2.得到每组的最小值后，从G列开始，比如第1组最小值1，那么只要G列数据，将第1组从A到E列以及G列复制到新建的表格（如最终）
3.如第2组最小值是2，那么要原始数据从G\H列，如第3组最小值是4，那么要原始数据的G/H/I/J列（标颜色部分）分别整理成最终表的形式
4.剩下还有没标颜色的就依次放到最后边

能VBA实现吗？

gwjkkkkk

理解不了什么意思。。。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr()
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("sheet1")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
9.         arr = .Range("a2").Resize(r - 1, c)
   
10.     End With
    
11.     ReDim brr(1 To 1000, 1 To 7)
    
12.     m = 0
    
13.     x = 0
    
14.     For k = 1 To UBound(arr) Step 6
    
15.         x = x + 1
    
16.         s = 10000
    
17.         For i = 1 To 6
    
18.            If i + k - 1 <= UBound(arr) Then
    
19.                 If s > arr(i + k - 1, 4) Then
    
20.                     s = arr(i + k - 1, 4)
    
21.                 End If
    
22.             End If
    
23.         Next
    
24.         For q = 1 To s
    
25.             For i = 1 To 6
    
26.                 If i + k - 1 <= UBound(arr) Then
    
27.                     m = m + 1
    
28.                     For j = 1 To 4
    
29.                         brr(m, j) = arr(i + k - 1, j)
    
30.                     Next
    
31.                     brr(m, 5) = x & "组"
    
32.                     brr(m, 7) = arr(i + k - 1, 7 + q - 1)
    
33.                 End If
    
34.             Next
    
35.         Next
    
36.                
    
37.     Next
    
38.     With Worksheets("最终")
    
39.         .Range("i2").Resize(m, UBound(brr, 2)) = brr
    
40.     End With
    
41. End Sub
    

复制代码

chxw68

详见附件。

chxw68

换个思路可能更好理解一些。

Ericcccccc

chxw68 发表于 2023-4-10 19:23
换个思路可能更好理解一些。

论坛总能出神迹~谢谢帮忙
但第4点似乎遗漏了，能帮忙再修改吗

chxw68

修改好了。

zxsea_7426

为了测试保留原数据，输出到sheet3(工作表名"sheet2")

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 i1 = i To i + 5
    
25.                 If i1 > r Then Exit For
    
26.                 For j = 7 + nn To c
    
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 j
    
36.             Next i1
    
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

复制代码

Ericcccccc

zxsea_7426 发表于 2023-4-10 23:45
为了测试保留原数据，输出到sheet3(工作表名"sheet2")

这个代码真香，有个小问题能否修改下？
需求4没有颜色那部分数据堆叠到最后时，代码按行遍历输出，比如第1组是B-F-12-A-V-Q的顺序，能否改成按列，如B-V-Q-F-12-A

Ericcccccc

chxw68 发表于 2023-4-10 22:04
修改好了。

有个小问题能否再帮下忙
需求4没有颜色那部分数据堆叠到最后时，代码按行遍历输出，比如第1组是B-F-12-A-V-Q的顺序，能否改成按列，如B-V-Q-F-12-A