求助优化代码，如何根据样品编号重排试验数据

753227299

如图，将左侧b3:d14重排到g3:j11,排列规则，原始表是同一个检验员的数据在一列，现在想把同一个样品编号的排在一列，刚学VBA不就，编的代码虽然能实现这个功能，但是太繁杂了，请求大家指点下怎么优化，谢谢！

代码如下：

1. Sub 重排()
   
2.     Dim arr, brr, m%
   
3.     arr = [a3:d14]
   
4.     ReDim brr(1 To UBound(arr) * UBound(arr, 2), 1 To 1)
   
5.     For i = 1 To UBound(arr)
   
6.         For j = 2 To UBound(arr, 2)
   
7.             If arr(i, 1) = 1 Then
   
8.                 m = m + 1
   
9.                 brr(m, 1) = arr(i, j)
   
10.             End If
    
11.         Next
    
12.     Next
    
13.     [g3].Resize(m, 1) = brr
    
14.     m = 0
    
15.     For i = 1 To UBound(arr)
    
16.         For j = 2 To UBound(arr, 2)
    
17.             If arr(i, 1) = 2 Then
    
18.                 m = m + 1
    
19.                 brr(m, 1) = arr(i, j)
    
20.             End If
    
21.         Next
    
22.     Next
    
23.     [h3].Resize(m, 1) = brr
    
24.     m = 0
    
25.     For i = 1 To UBound(arr)
    
26.         For j = 2 To UBound(arr, 2)
    
27.             If arr(i, 1) = 3 Then
    
28.                 m = m + 1
    
29.                 brr(m, 1) = arr(i, j)
    
30.             End If
    
31.         Next
    
32.     Next
    
33.     [i3].Resize(m, 1) = brr
    
34.     m = 0
    
35.     For i = 1 To UBound(arr)
    
36.         For j = 2 To UBound(arr, 2)
    
37.             If arr(i, 1) = 4 Then
    
38.                 m = m + 1
    
39.                 brr(m, 1) = arr(i, j)
    
40.             End If
    
41.         Next
    
42.     Next
    
43.     [j3].Resize(m, 1) = brr
    
44. End Sub
    

复制代码

求助.rar (13.05 KB, 下载次数: 10)

2019-12-14 00:20 上传

点击文件名下载附件

山菊花

Sub 重排()
    Dim nRow%, Arr(), Brr(), i%, i1%, i2%
    nRow = Range("a65536").End(xlUp).Row - 2 '数据行数
    Arr = Range("b3").Resize(nRow, 3).Value
    ReDim Brr(1 To 3 * nRow / 4, 1 To 4)
    For i = 1 To nRow Step 4 '每4行为一块划分
        i2 = (i - 1) * 3 / 4 'Brr中开始的行号
        For i1 = 1 To 4 '循环当前数据块的行
            For j = 1 To 3 '循环3列
                Brr(i2 + j, i1) = Arr(i + i1 - 1, j) '读写数据
            Next
        Next
    Next
    Range("g3").Resize(UBound(Brr), 4).Value = Brr '输出数据
End Sub

feiyang8878

山菊花 发表于 2019-12-14 08:48
Sub 重排()
    Dim nRow%, Arr(), Brr(), i%, i1%, i2%
    nRow = Range("a65536").End(xlUp).Row - 2  ...

这数组赋值，+ value 与不加的区别是啥？我看论坛好多都是不加，请总版主帮忙回答一下，谢谢

feiyang8878

1. Sub test()
   
2.     Dim arr, i%, j%
   
3.     Sheet1.Range("g3:j11").ClearContents
   
4.     For i = 3 To Sheet1.Range("A5000").End(xlUp).Row
   
5.        If Sheet1.Cells(i, 1) = 1 Then
   
6.            arr = Sheet1.Range("B" & i).Resize(4, 3)
   
7.            For j = 3 To Sheet1.Range("f5000").End(xlUp).Row
   
8.                If Sheet1.Cells(j, 6) = "甲" And Sheet1.Cells(j, 7) = "" Then
   
9.                    Sheet1.Range("G" & j).Resize(UBound(arr, 2), UBound(arr)) = _
   
10.                    Application.WorksheetFunction.Transpose(arr)
    
11.                    Exit For
    
12.                End If
    
13.            Next
    
14.        End If
    
15.     Next
    
16. End Sub
    
17. 
    
18. 数据固定就用总版主那个吧，不固定可以尝试用这个试试

复制代码

山菊花

feiyang8878 发表于 2019-12-14 09:13
这数组赋值，+ value 与不加的区别是啥？我看论坛好多都是不加，请总版主帮忙回答一下，谢谢

陌生人见面，通常问：你叫什么？你叫什么名？
向别人介绍自己，也是，我叫山菊花，我的名叫山菊花。
这个“名”在这个场景中，是人的默认属性，可用，可省略。
老师公布学生成绩时，会说，张三的成绩100分，李四98分（这里就省略了“成绩”）。
Value也一样，它是单元格默认的属性，一般可省略。

feiyang8878

山菊花 发表于 2019-12-14 09:21
陌生人见面，通常问：你叫什么？你叫什么名？
向别人介绍自己，也是，我叫山菊花，我的名叫山菊花。
这 ...

谢谢总版主回答~明白了

753227299

山菊花 发表于 2019-12-14 08:48
Sub 重排()
    Dim nRow%, Arr(), Brr(), i%, i1%, i2%
    nRow = Range("a65536").End(xlUp).Row - 2  ...

谢谢总版主帮助，还有一个问题忘记在里面体现了，实际表格中，最后输入数据的区域不在连续的四列中，请问总如何指定样品1在某列，样品2在某列？比如样品1在g3、样品2在i3、样品3在k3、样品4在m3输出，烦请总版主指定迷津，谢谢！

753227299

feiyang8878 发表于 2019-12-14 09:15

感谢帮助！

山菊花

753227299 发表于 2019-12-14 09:51
谢谢总版主帮助，还有一个问题忘记在里面体现了，实际表格中，最后输入数据的区域不在连续的四列中，请问 ...

请提供附件。

753227299

山菊花 发表于 2019-12-14 09:57
请提供附件。

求助（输出数据区域不连续）.rar (15.81 KB, 下载次数: 2)

2019-12-14 10:05 上传

点击文件名下载附件

请总版主查收，感谢！