怎么用VBA在自定列换行，谢谢

daiy3648

如上图怎么在sheet2里面自动实现。

daiy3648

感激不尽！

笨鸟飞不高

求助.rar (17 KB, 下载次数: 9)

2020-9-26 21:52 上传

点击文件名下载附件

凑一个！！！

daiy3648

笨鸟飞不高 发表于 2020-9-26 21:50
凑一个！！！

这么快，谢谢

笨鸟飞不高

Sub AwDemo()
    Dim i&, j%, k%, r&, arr
    With Sheet1
        arr = .[a1].CurrentRegion
        ReDim brr(1 To UBound(arr, 2), 1 To 12)
        r = 1: brr(r, 2) = "合计"
        For i = 2 To UBound(arr)
            For j = 3 To UBound(arr, 2) Step 10
                If Len(arr(i, j)) Then
                    r = r + 1
                    If j = 3 Then brr(r, 1) = arr(i, 1): brr(r, 2) = arr(i, 2)
                    For k = 0 To 9
                        If j + k <= UBound(arr, 2) Then brr(r, k + 3) = arr(i, j + k) Else GoTo 100
                    Next
                End If
            Next
100:
        Next
    End With
    With Sheet2
        .Cells.Clear
        .[a1].Resize(r, 12) = brr
    End With
End Sub

f8b1987

1. Sub 分行代码()
   
2. t = Timer
   
3.     With Sheets("原数据")
   
4.             crr = .[a1].CurrentRegion
   
5.             col = .Range("A1").Offset(0, UBound(crr, 2) + 10).Address(0, 0)
   
6.             myrow = UBound(crr)
   
7.             myc = Left(col, Len(col) - 1)
   
8.             Erase crr
   
9.             arr = .Range("A1:" & myc & myrow + 10)
   
10.     End With
    
11.     ReDim brr(1 To UBound(arr) * UBound(arr, 2), 1 To UBound(arr, 2))
    
12.     n = 2
    
13.     brr(1, 2) = "合计"
    
14.     For x = 2 To UBound(arr)
    
15.             brr(n, 1) = arr(x, 1)
    
16.             brr(n, 2) = arr(x, 2)
    
17.             For y = 3 To UBound(arr, 2) Step 10
    
18.                 If arr(x, y) <> "" Then
    
19.                         For i = 1 To 10
    
20.                             brr(n, i + 2) = arr(x, y + i - 1)
    
21.                         Next i
    
22.                         n = n + 1
    
23.                 End If
    
24.             Next y
    
25.     Next x
    
26.     Erase arr
    
27.     With Sheets("Sheet1")
    
28.             .Cells.ClearContents
    
29.             .Range("A1").Resize(n, 12) = brr
    
30.     End With
    
31.     Erase brr
    
32.     MsgBox Timer - t
    
33. End Sub

复制代码

f8b1987

10列一换行代码.zip (92.97 KB, 下载次数: 2)

2020-9-27 09:49 上传

点击文件名下载附件

9.27日更新

daiy3648

笨鸟飞不高 发表于 2020-9-26 21:50
凑一个！！！

有点问题，K、L、M项漏了，是还要加个循环吗？

renkangjizhen

Sub test()
Dim arr, brr, i&, m&, x&, y&, z&, p&, w%, rng As Range
On Error Resume Next
Sheets("原数据").Select
arr = Range([a1], [b65536].End(3))
i = [a65536].End(3).Row
m = [aaa3].End(xlToLeft).Column
brr = Range([c2], Cells(i, m))
p = 0
Sheet2.Select
[a1:z500].ClearContents
[b1] = arr(1, 2): [a2] = arr(2, 1): [b2] = arr(2, 2)
For x = 1 To UBound(brr)
    For y = 1 To UBound(brr, 2)
    z = (y - 1) \ 12 + 1 + p: w = (y - 1) Mod 12 + 1
    Cells(z + 1, w + 2) = brr(x, y)
    Next
Set rng = [c65536].End(3)
If x + 2 > UBound(arr) Then Exit For
rng.Offset(1, -2) = arr(x + 2, 1): rng.Offset(1, -1) = arr(x + 2, 2)
Set rng = Nothing
p = z - 1
Next
End Sub

renkangjizhen

代码在附件中