如何用vba代码实现选择的列拆分成固定行数的区域？

作者：绿色风分类：时间：2022-08-17 浏览：91

楼主
kevinchengcw

Q: 如何用vba代码实现选择的列拆分成固定行数的区域？
A: 代码如下：

Sub test()
Dim Rng As Range, N&, I&, T&, Arr, Arr2, R As Range
On Error GoTo Skip '设定出错跳转
Set Rng = Application.InputBox("请用鼠标选择要转换的列区域(单列):", "选择区域", , , , , , 8) '取得数据区域
N = Application.InputBox("请输入拆分后的行数:", "输入行数", , , , , 1) '取得要拆分成的行数
Set R = Application.InputBox("请用鼠标选择目标区域的第一个单元格:", "选择目标", , , , , , 8) '取得目标区域位置
Arr = Rng.Columns(1).Formula '提取选定区域内第一列的数据
I = IIf(Int(UBound(Arr) / N) = UBound(Arr) / N, UBound(Arr) / N, Int(UBound(Arr) / N) + 1) '取得拆分后的列数
ReDim Arr2(1 To N, 1 To I) '重定义下数组维数
I = 1: T = 1 '初始化下标值
For N = 1 To UBound(Arr) '循环原始数据
Arr2(I, T) = Arr(N, 1) '将原始数据写入新的二维数组
I = I + 1 '下标递增
If I > UBound(Arr2) Then I = 1: T = T + 1 '当下标超出上限后转到数且下一列第一个
Next N
With R(1).Resize(UBound(Arr2), UBound(Arr2, 2)) '定义一个选定目标区域第一个单元格与数组维数相同的区域
.MergeCells = False '取消里面可能存在的合并单元格
.Value = Arr2 '写入数组数据
End With
Exit Sub '正常运行时的退出位置
Skip:
MsgBox "出错退出" '出错时的提示
End Sub

2楼
成就滋味

谢谢分享

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素，经与ExcelTip.Net站长Apolloh商议并征得其同意，现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示，供有需要的人士查询使用，也慰缅曾经的论坛时代。所示各个帖子的原作者如对版权有异议，可与本人沟通提出，或于本站点留言，我们会尽快处理。在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一

评论列表