横排变竖排

vince01023

请教：如图，要跳过空格，把区域内的数据每三个一行，排成一列，谢谢赐教。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.9.20
   
2.     arr = [a1].CurrentRegion
   
3.     ReDim brr(1 To 10000, 1 To 3)
   
4.     For j = 1 To UBound(arr, 2) Step 3
   
5.         For i = 1 To UBound(arr)
   
6.             If arr(i, j) <> Empty Then
   
7.                 m = m + 1
   
8.                 brr(m, 1) = arr(i, j)
   
9.                 brr(m, 2) = arr(i, j + 1)
   
10.                 brr(m, 3) = arr(i, j + 2)
    
11.             End If
    
12.         Next
    
13.     Next
    
14.     [a8].Resize(1000, 3) = ""
    
15.     [a8].Resize(m, 3) = brr
    
16.     MsgBox "OK！"
    
17. End Sub
    

复制代码

songshihai

函数法!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    arr = Sheet1.[a1].CurrentRegion
    ReDim brr(1 To 10000, 1 To 3)
    n = 0
    For i = 1 To UBound(arr)
        For j = 1 To UBound(arr, 2) Step 3
            If arr(i, j) <> Empty Then
                n = n + 1
                For k = 1 To 3
                    brr(n, (k - 1 Mod 3) + 1) = arr(i, j + k - 1)
                Next
            End If
        Next
    Next
    With Sheet1
        .[f8].Resize(n, 3) = brr
        .[f8].CurrentRegion.Borders.LineStyle = 1
        .[f8].CurrentRegion.HorizontalAlignment = xlCenter
    End With
    Beep
End Sub

quqiyuan

PQ方法也方便，供参考。。。

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, k&, r&
   
    Application.ScreenUpdating = False
   
    ar = [A1].CurrentRegion.Value
    ReDim br(1 To UBound(ar) * 10, 1 To 3)
    For i = 1 To UBound(ar)
        For j = 1 To UBound(ar, 2) Step 3
            If Len(ar(i, j)) Then
                r = r + 1
                For k = 1 To 3
                    br(r, k) = ar(i, j - 1 + k)
                Next k
               
            End If
        Next j
    Next i
        
    With [a8].Resize(r, UBound(br, 2))
        .Value = br
        .Borders.LineStyle = 1
    End With
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

。。。。。。。。。。。