VBA将列表转换为5列表格

我有一个列表（垂直），我想把它排列成表格。 假设我有大约23份清单。我想安排在5列中，每列跳过一行。 此列表样式的示例

a
b
c
d
e
f
g
h
i
j
k
l
m
n
o
p
q
r
s
t
u
v
w

采用这种格式

 1| a | b | c | d | e |
 2|   |   |   |   |   |
 3| f | g | h | i | j |
 4|   |   |   |   |   |
 5| k | l | m | n | o |
 6|   |   |   |   |   |
 7| p | q | r | s | t |
 8|   |   |   |   |   |
 9| u | v | w |   |   |
10|   |   |   |   |   |

---

我曾想过使用循环和“step”，但我不确定它是否会起作用，因为您使用的是小数据，两个循环应该不会有任何问题。即使是小数据，我还是建议您使用数组，而不是一次一个地将每个值读/写到工作表中

您可以创建两个数组变量，

OldArr（）

和

NewArr（）

。您将把现有的数据列放入

OldArr（）

并清除数据，因为您将用5x5覆盖它

然后使用

NewArr（）

，您只需在工作表的行/列表示中循环，并根据需要重新组织数据。然后一次性将整个数组写入工作表

像这样的方法应该会奏效：

Option Explicit

Sub ColumnDataToBox()

    Dim ws As Excel.Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    Dim OldArr() As Variant
    With ws.Range("A1:A25")
        OldArr = .Value
        .Clear
    End With
    
    Dim NewArr(1 To 9, 1 To 5) As Variant, c As Long, r As Long, i As Long
    For r = 1 To 9 Step 2
        For c = 1 To 5
            i = i + 1
            NewArr(r, c) = OldArr(i, 1)
        Next c
    Next r

    ws.Range("A1:E9").Value = NewArr

End Sub

这将假定数据大小从不大于25行（因为您要求的是5x5），因此此代码不是动态的

这项工作：

Cells.Clear
For i = 1 To 23 ' make data
Cells(i, 1) = Chr(96 + i)
Next i
For i = 1 To 23 ' transform data
Cells(((i - 1) \ 5) * 2 + 1, (i - 1) Mod 5 + 1) = Cells(i, 1)
If i > 1 Then Cells(i, 1).Clear
Next i

它使用公式计算单元的新位置，因此不需要中间数组

从列中获取列

• 第一个子项显示如何使用第二个子项，即主子项（

  getColumnsFromColumn

  ）
• 第三个子系统由主子系统调用（也是必要的）

代码

Option Explicit

Sub testGetColumnsFromColumn()
    
    ' Source
    Const srcName As String = "Sheet1"
    Const srcColumnID As Variant = "A" ' e.g. 1 or "A"
    Const srcFirstRow As Long = 1
    ' Target
    Const tgtName As String = "Sheet2"
    Const tgtFirstCell As String = "A1"
    Const NumberOfColumns As Long = 5
    Const EmptyRows As Long = 1
    ' Other
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Define source worksheet.
    Dim src As Worksheet:  Set src = wb.Worksheets(srcName)
    
    ' Write result to array.
    Dim Data As Variant
    getColumnsFromColumn Data, src, NumberOfColumns, _
        EmptyRows, srcColumnID, srcFirstRow
    If IsEmpty(Data) Then Exit Sub
    
    ' Write array to target worksheet.
    Dim tgt As Worksheet: Set tgt = wb.Worksheets(tgtName)
    tgt.Cells.ClearContents
    tgt.Range(tgtFirstCell).Resize(UBound(Data), UBound(Data, 2)) _
       .Value = Data

    ' Inform user.
    MsgBox "Success"

End Sub

Sub getColumnsFromColumn(ByRef Data As Variant, _
                         Sheet As Worksheet, _
                         ByVal NumberOfColumns As Long, _
                         Optional ByVal EmptyRows As Long = 0, _
                         Optional ByVal ColumnID As Variant = 1, _
                         Optional ByVal FirstRow As Long = 1)

    Data = Empty
    
    Dim ColumnData As Variant
    getColumn ColumnData, Sheet, ColumnID, FirstRow
    If IsEmpty(ColumnData) Then Exit Sub

    Dim ub As Long: ub = UBound(ColumnData)
    Dim FullSets As Long: FullSets = Int(ub / NumberOfColumns)
    Dim NoS As Long: NoS = FullSets
    Dim Remainder As Long: Remainder = ub Mod NumberOfColumns
    If Remainder > 0 Then NoS = NoS + 1
    
    ReDim Data(1 To NoS + EmptyRows * NoS - 1, 1 To NumberOfColumns)
    
    Dim i As Long, j As Long, k As Long, CurrentRow As Long
    GoSub writeFullSets
    If Remainder > 0 Then GoSub writeRemainder

    Exit Sub

writeFullSets:
    For i = 1 To FullSets
        CurrentRow = (EmptyRows + 1) * i - EmptyRows
        For j = 1 To NumberOfColumns
            k = k + 1
            Data(CurrentRow, j) = ColumnData(k, 1)
        Next j
    Next i
    Return

writeRemainder:
    CurrentRow = (EmptyRows + 1) * i - EmptyRows
    For j = 1 To Remainder
        k = k + 1
        Data(CurrentRow, j) = ColumnData(k, 1)
    Next j
    Return

End Sub

Sub getColumn(ByRef Data As Variant, _
              Sheet As Worksheet, _
              Optional ByVal ColumnID As Variant = 1, _
              Optional ByVal FirstRow As Long = 1)
    Data = Empty
    Dim rng As Range
    Set rng = Sheet.Columns(ColumnID).Find("*", , xlValues, , , xlPrevious)
    If rng Is Nothing Then Exit Sub
    If rng.Row < FirstRow Then Exit Sub
    If rng.Row > FirstRow Then
        Data = Sheet.Range(Sheet.Cells(FirstRow, ColumnID), rng).Value
    Else
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rng.Value
    End If
End Sub

选项显式
子testGetColumnsFromColumn（）
"来源:
Const srcName As String=“Sheet1”
Const srcColumnID作为Variant=“A”例如1或“A”
常量srcFirstRow的长度=1
"目标"
Const tgtName As String=“Sheet2”
常量tgtFirstCell为String=“A1”
常量NumberOfColumns的长度=5
当长=1时，常量为空
“其他的
将wb设置为工作簿：设置wb=ThisWorkbook
'定义源工作表。
将src标注为工作表：设置src=wb.Worksheets（srcName）
'将结果写入数组。
作为变量的Dim数据
getColumnsFromColumn数据、src、NumberOfColumns、_
EmptyRows、srcColumnID、srcFirstRow
如果为空（数据），则退出Sub
'将数组写入目标工作表。
将tgt设置为工作表：设置tgt=wb.工作表（tgtName）
tgt.Cells.ClearContents
tgt.Range（tgtFirstCell）.Resize（UBound（数据），UBound（数据，2））_
.值=数据
'通知用户。
MsgBox“成功”
端接头
子getColumnsFromColumn（ByRef数据作为变量_
工作表作为工作表_
ByVal NumberOfColumns的长度_
可选ByVal EmptyRows，只要长=0_
变量为1的可选ByVal ColumnID_
可选的ByVal FirstRow（长度=1）
数据=空
Dim列数据作为变量
getColumn ColumnData，工作表，ColumnID，第一行
如果为空（ColumnData），则退出Sub
长度为的尺寸ub:ub=UBound（ColumnData）
按长度调整完整集：完整集=Int（ub/NumberOfColumns）
长度尺寸：数量=全套
按长度调整余数：余数=ub Mod NumberOfColumns
如果余数大于0，则NoS=NoS+1
ReDim数据（1到个+空箭头*个-1，1到NumberOfColumns）
尺寸i为长，j为长，k为长，CurrentRow为长
GoSub WriteFileSets
如果余数>0，则GoSub WriterMainder
出口接头
可写列表：
对于i=1到全套
CurrentRow=（清空Rows+1）*i-清空Rows
对于j=1到NumberOfColumns
k=k+1
数据（CurrentRow，j）=列数据（k，1）
下一个j
接下来我
返回
WriterMainder：
CurrentRow=（清空Rows+1）*i-清空Rows
对于j=1到余数
k=k+1
数据（CurrentRow，j）=列数据（k，1）
下一个j
返回
端接头
子getColumn（ByRef数据作为变量_
工作表作为工作表_
变量为1的可选ByVal ColumnID_
可选的ByVal FirstRow（长度=1）
数据=空
变暗rng As范围
Set rng=Sheet.Columns（ColumnID）.Find（“*”，xlValues，，xlPrevious）
如果rng为空，则退出Sub
如果rng.Row<第一行，则退出Sub
如果rng.Row>第一行，则
数据=Sheet.Range（Sheet.Cells（FirstRow，ColumnID），rng）.Value
其他的
ReDim数据（1对1，1对1）：数据（1，1）=rng.值
如果结束
端接头

一个外部循环，步骤为2以增加行数，内部循环为5倍以增加列数并获取和插入下一个列表项。这是我的自然想法。尝试在Office帮助文档的帮助下进行编码，并使用step进行调试。我对“垂直”和“a”到“w”感到困惑，这将推断出一个水平列表。原始数据是垂直的（上下）还是水平的（从左到右）？你有“大约23”，这是否意味着这种情况会改变？我会假设，即使是这样，你也不会有超过25个，因为你要求的是5x9（行距）。如果你能更详细地回答你的问题，肯定会有帮助。好的，我已经编辑了。抱歉搞混了，嘿，戴维斯。到目前为止，我发现你的答案很容易理解。但是，我的错误是没有在前面提到，但是如果我复制列表并粘贴到另一张表中的一个表中呢。我被困在这里了。我试着激活床单。这个环很好。我觉得数组也不错。但是当我跑的时候，桌子是空的。好像什么也没发生一样不确定我是否理解你的要求，但是

结束子部分上方的最后一行

将

ws.

替换为

Sheet3.

。您可以使用工作表的变量，而不是使用变量。这将把数据放入sheet3，同时仍然从sheet1.Hi JMP复制。我很难理解你的方法。命令Chr（96+i）对我来说是新的。我可以知道是什么吗