横排变竖排

vince01023 · 发表于 2024-9-20 16:28

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

ykcbf1100 · 发表于 2024-9-20 16:35

附件供参考。。。

ykcbf1100 · 发表于 2024-9-20 16:36

参与一下。。。

Sub ykcbf() '//2024.9.20
arr = [a1].CurrentRegion
ReDim brr(1 To 10000, 1 To 3)
For j = 1 To UBound(arr, 2) Step 3
For i = 1 To UBound(arr)
If arr(i, j) <> Empty Then
m = m + 1
brr(m, 1) = arr(i, j)
brr(m, 2) = arr(i, j + 1)
brr(m, 3) = arr(i, j + 2)
End If
Next
Next
[a8].Resize(1000, 3) = ""
[a8].Resize(m, 3) = brr
MsgBox "OK！"
End Sub

复制代码

songshihai · 发表于 2024-9-20 16:39

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

quqiyuan · 发表于 2024-9-20 16:57

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

quqiyuan · 发表于 2024-9-20 16:57

代码如下。。。
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 · 发表于 2024-9-20 17:04

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

gwjkkkkk · 发表于 2024-9-20 19:19

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 · 发表于 2024-9-20 19:20

。。。。。。。。。。。

		自动登录	找回密码
密码			免费注册

[求助] 横排变竖排

评分

评分

评分

评分

评分