表格转换

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.5.17
   
2.     With Sheets("Sheet1")
   
3.         r = .Cells(Rows.Count, 1).End(3).Row
   
4.         arr = .[a1].Resize(r, 1)
   
5.     End With
   
6.     ReDim brr(1 To UBound(arr), 1 To 8)
   
7.     On Error Resume Next
   
8.     For i = 1 To UBound(arr) Step 8
   
9.         m = m + 1
   
10.         For x = 1 To 8
    
11.             brr(m, x) = arr(i + x - 1, 1)
    
12.         Next
    
13.     Next
    
14.     With Sheets("Sheet2")
    
15.         .UsedRange.Offset(3).Clear
    
16.         .Columns("c:g").NumberFormatLocal = "@"
    
17.         With .[a4].Resize(m, 8)
    
18.             .Value = brr
    
19.             .Borders.LineStyle = 1
    
20.             .HorizontalAlignment = xlCenter
    
21.             .VerticalAlignment = xlCenter
    
22.         End With
    
23.     End With
    
24.     MsgBox "OK！"
    
25. End Sub
    

复制代码

APPLE123

ykcbf1100 发表于 2024-5-17 08:16
参与一下。。。

谢谢老师的帮助

jjmysjg

taller 发表于 2024-5-16 13:11

最后一组没有进去，

taller

jjmysjg 发表于 2024-5-18 12:28
最后一组没有进去，

笔误，请修改 With Range("A3").Resize(iR+1, 8)

Qs18

Sub test()
k = 4 '换行的变量
For j = 1 To Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    i = i + 1 '列的递增
        Sheet2.Cells(k, i).Value = Sheet1.Cells(j, 1)
        If i Mod 8 = 0 Then '如果能够被8整除说明该换行了
        k = k + 1 '就加1向下一行
        i = 0 '把列的递增，又从回0
        End If
Next j
MsgBox "完成！"
End Sub