按数量转置

可乐的乐

SHEET1有ABCDG四列数据，每五行转成一行中间用列隔开，然后每行数据之间隔五行

tmplinshi

1. Sub Main()
   
2. 
   
3.     Const 舍弃不足5行 = False
   
4. 
   
5.     Dim arrIn(), arrOut(), r%, c%
   
6.     Dim rOut%: rOut = 5
   
7.     Dim cOut%: cOut = 1
   
8.    
   
9.     arrIn = Sheet1.Range("A1").CurrentRegion.Value
   
10.     ReDim arrOut(1 To Round(UBound(arrIn) / 5) * 5, 1 To 24)
    
11.    
    
12.     For r = 1 To UBound(arrIn)
    
13.         For c = 1 To 4
    
14.             arrOut(rOut, cOut) = arrIn(r, c)
    
15.             cOut = cOut + 1
    
16.         Next
    
17.         
    
18.         cOut = cOut + 1
    
19. 
    
20.         If (r Mod 5) = 0 Then
    
21.             rOut = rOut + 5
    
22.             cOut = 1
    
23.         End If
    
24.     Next
    
25.    
    
26.     Dim rowSize%: rowSize = IIf(舍弃不足5行, UBound(arrIn), UBound(arrOut))
    
27.     With Sheet2
    
28.         .UsedRange.ClearContents
    
29.         .Range("A1").Resize(rowSize, 24).Value = arrOut
    
30.     End With
    
31.    
    
32. End Sub

复制代码

hhlty

Sub t()
    Dim ar, br(1 To 1000, 1 To 24), tr, i
    ar = Sheet1.[a1].CurrentRegion
    For i = 1 To UBound(ar)
        For j = 1 To 4
            s = s & ar(i, j) & ";"
        Next j
        s = s & " ;"
        If i Mod 5 = 0 Then
            tr = Split(s, ";")
            For k = 1 To 24
                br(i, k) = tr(k - 1)
            Next k
            s = ""
        End If
    Next i
    Sheet2.[a1].Resize(UBound(br), 24) = br
End Sub

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.12
   
2.     Dim arr, brr
   
3.     r = Cells(Rows.Count, 1).End(3).Row
   
4.     arr = Sheet1.Range("a1:d" & r)
   
5.     ReDim brr(1 To UBound(arr), 1 To 100)
   
6.     On Error Resume Next
   
7.     For i = 1 To UBound(arr) Step 5
   
8.         m = m + 5
   
9.         n = 0
   
10.         For x = 1 To 5
    
11.             For j = 1 To UBound(arr, 2)
    
12.                 n = n + 1
    
13.                 brr(m, n) = arr(i + x - 1, j)
    
14.             Next
    
15.             n = n + 1
    
16.         Next
    
17.         Max = IIf(Max < n, n, Max)
    
18.     Next
    
19.     With Sheet2
    
20.         .UsedRange = ""
    
21.         .[a1].Resize(m, Max) = brr
    
22.     End With
    
23.     MsgBox "OK！"
    
24. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

可乐的乐

ykcbf1100 发表于 2024-1-12 10:47
附件供参考。。。

大神不太对，只转换了A/F/K/P的数据，其他行数据没有了

cidanji

1. Sub ss()
   
2. Dim ar, br, l&, h&, i&, j&, u1&, u2&, x&, y&
   
3. l = 5 '希望列数
   
4. h = 5 '1行展开成几行
   
5. With Sheet1
   
6.     ar = .Range("A1:D" & .Cells(.Rows.Count, 1).End(3).Row) '取数
   
7.     u1 = UBound(ar): u2 = UBound(ar, 2)
   
8.     ReDim br(1 To -Int(-u1 / l) * h, 1 To (u2 + 1) * l)
   
9. End With
   
10. For i = 1 To u1
    
11.     x = Int((i + l - 1) / l) * h
    
12.     y = ((i + l - 1) Mod l) * (u2 + 1)
    
13.     For j = 1 To u2
    
14.         br(x, y + j) = ar(i, j)
    
15.     Next
    
16. Next
    
17. '回填在sheet2
    
18. Sheet2.Cells.ClearContents
    
19. Sheet2.Cells.HorizontalAlignment = xlHAlignCenter
    
20. Sheet2.[A1].Resize(UBound(br), UBound(br, 2)) = br
    
21. End Sub

复制代码

ykcbf1100

可乐的乐 发表于 2024-1-12 10:56
大神不太对，只转换了A/F/K/P的数据，其他行数据没有了

修改好了。。。

cidanji

笨鸟飞不高