01 工作表
行列交叉二维数据表转成一维数据表的方法
日常工作中常会遇到这样的行列交叉的二维数据表：
如果想要把转成一维数据(如下图)，用VBA代码来实现特别容易！
也借用这个实现过程，重点复习下VBA的嵌套循环和数组使用。
运行视频：
源码下载：
描述：
行列交叉的二维数据表，转一维数据表，以供透视或其他分析使用。
样本示例：
结果示例：
需求分析：
- 1、支持自主选择需要转换的区域；
- 2、转换结果保存在一个新增表内；
VBA实现过程：
- 1.Application.InputBox(Text, Type:=8)，自主选择，Type类型是单元格；
- 2.新增一个工作表保存结果；
- 3.主程序逻辑实现过程
- ①对选择的单元格区域，双层循环，
- ②第一行内容的从第一列到最后一列，第二行......、第三行....，直到结束，
- ③Dim Arr() As Variant，ReDim Preserve Arr(1 To 3, 1 To j)，循环中，3 × N动态数组保存原单元格的值，
- ④调用内置函数.Transpose(Arr)转换数组，一次写入到新增的工作表中，.Resize方法“扩张”单元格的区域，接收数组的值，
- 4.完成！
示例代码
复制成功!
1
Sub 二维数据转换为一维()
'--------------------------------------------------------------------
'自定义数据类型
Dim Choose_rng As Range
Dim Choose_sht_name As String
Dim Choose_rng_row, Choose_rng_column As Integer
Dim Sht As Worksheet
Dim i, j As Long
Dim Arr() As Variant
'选择需要转换的单元格区域，获取选择单元格的表名、区域起始行、起始列
Set Choose_rng = Application.InputBox("选择需要被转换的二维数据区域", Type:=8)
If WorksheetFunction.CountA(Choose_rng) = 0 Then MsgBox "选择单元格区域为空": Exit Sub
Choose_sht_name = Choose_rng.Parent.Name
Choose_rng_row = Choose_rng.Row
Choose_rng_column = Choose_rng.Column
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'判断工作簿中是否存心转换的结果表，如果有则删除重新增加一个表
For Each Sht In ThisWorkbook.Sheets
If Sht.Name = Choose_sht_name & "转换结果" Then Sht.Delete
Next Sht
Worksheets.Add after:=Sheets(Choose_sht_name)
ActiveSheet.Name = Choose_sht_name & "转换结果"
'遍历需要转换的数据区域，包括纵向循环和横向循环，将转换结果赋值给数值并粘贴到新的工作表
Sheets(Choose_sht_name).Select
For i = 1 To Choose_rng.Rows.Count - 1
For j = 1 To Choose_rng.Columns.Count - 1
ReDim Preserve Arr(1 To 3, 1 To j)
Arr(1, j) = Cells(i + Choose_rng_row, Choose_rng_column).Value
Arr(2, j) = Cells(Choose_rng_row, j + Choose_rng_column).Value
Arr(3, j) = Cells(i + Choose_rng_row, j + Choose_rng_column).Value
Next j
' 3 * N,.Transpose(Arr)转换成 N * 3，.Resize方法“扩张”单元格的区域，接收数组的值
Sheets(Choose_sht_name & "转换结果").Cells((i - 1) * UBound(Arr, 2) + 1, 1).Resize(UBound(Arr, 2), UBound(Arr)) = WorksheetFunction.Transpose(Arr)
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "转换完成"
Sheets(Choose_sht_name & "转换结果").Activate
End Sub
请开发者喝杯咖啡！