Excel·VBA表格横向、纵向相互转换

如图：对图中区域 A1:M6 横向表格，转换成区域 A1:C20 纵向表格，即 B:M 列转换成每2列一组按行写入，并删除空行。同理，反向操作就是纵向表格转换成横向表格

横向转纵向

实现方法1

对本文图1中，按“交期和交货数量”每5行2列为一组，依次按行写入，即按“交期”顺序排列

Sub 表格横向转纵向1()'分段转换，转换列之前同名不连续；不使用动态获取每行最后一列是考虑到部分选中拆分Dim num_col&, title_row&, del_empty As Boolean, rng As Range, del_rng As RangeDim first_col&, resize_r&, resize_c&, keep_rng, arr, brr, b$, r&, i&, j&
'--------------------参数填写：num_col、title_row都为数字，选中后才可运行代码num_col = 2    '需要拆分的数据每行固定的列数title_row = 1  '表头行数del_empty = True  '是否删除空行If Selection.Count = 1 Then Debug.Print "未选中列，无法运行代码": Exit SubSet rng = Intersect(ActiveSheet.UsedRange, Selection)  'intersect语句避免选择整列造成无用计算'选中区域开始列号，转换行数、列数first_col = rng.column: resize_r = rng.Rows.Count - title_row: resize_c = rng.Columns.CountIf resize_c Mod num_col <> 0 Then Debug.Print "选中列数不可平分": Exit SubWith ActiveSheetkeep_rng = .Cells(title_row + 1, 1).Resize(resize_r, first_col - 1)  '不变区域arr = .Cells(title_row + 1, first_col).Resize(resize_r, resize_c)    '转换区域r = title_row + 1  '写入行号For i = num_col + 1 To UBound(arr, 2) Step num_colr = r + resize_r: .Cells(r, 1).Resize(resize_r, first_col - 1) = keep_rngFor j = 1 To num_colbrr = Application.index(arr, , i + j - 1)  '按列拆分.Cells(r, first_col + j - 1).Resize(resize_r, 1) = brrNextNextIf del_empty Then  '删除空行For i = title_row + 1 To r + resize_rbrr = .Cells(i, first_col).Resize(1, num_col)b = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(brr)), "")If Len(b) = 0 ThenIf del_rng Is Nothing ThenSet del_rng = .Rows(i)ElseSet del_rng = Union(del_rng, .Rows(i))End IfEnd IfNextIf Not del_rng Is Nothing Then del_rng.Delete  '删除行End If.Cells(1, first_col + num_col).Resize(1, resize_c - num_col).EntireColumn.Delete  '删除选中列End With
End Sub

转换结果

对本文图1（转换前不含7-20行），选中 B:M 列，运行代码得到如下图结果： D:M 列被删除

实现方法2

对本文图1中，按“产品规格”每个产品后面6组“交期和交货数量”转换为每6行2列，依次按行写入，即按“产品”顺序排列

以下代码使用了数组行列数转换函数，调用了wraparr函数，代码详见《Excel·VBA单元格区域行列数转换函数》（如需使用代码需复制）

Sub 表格横向转纵向2()'按行转换，转换列之前同名连续；不使用动态获取每行最后一列是考虑到部分选中拆分Dim num_col&, title_row&, del_empty As Boolean, rng As Range, del_rng As RangeDim first_col&, last_row&, resize_r&, resize_c&, keep_rng, arr, brr, b$, r&, i&, j&
'--------------------参数填写：num_col、title_row都为数字，选中后才可运行代码num_col = 2    '需要拆分的数据每行固定的列数title_row = 1  '表头行数del_empty = True  '是否删除空行If Selection.Count = 1 Then Debug.Print "未选中列，无法运行代码": Exit SubSet rng = Intersect(ActiveSheet.UsedRange, Selection)  'intersect语句避免选择整列造成无用计算'选中区域开始列号、结束行号，转换行数、列数first_col = rng.column: last_row = rng.Rows.Countresize_r = rng.Rows.Count - title_row: resize_c = rng.Columns.Count: r = resize_c / num_colIf resize_c Mod num_col <> 0 Then Debug.Print "选中列数不可平分": Exit SubWith ActiveSheetFor i = last_row To title_row + 1 Step -1  '倒序循环keep_rng = .Cells(i, 1).Resize(1, first_col - 1)  '不变区域arr = .Cells(i, first_col).Resize(1, resize_c)    '转换区域arr = wraparr(arr, "row", r)  '调用函数将arr转换为r行num_col的数组.Cells(i + 1, 1).Resize(r - 1, 1).EntireRow.Insert  '插入行.Cells(i, 1).Resize(r, first_col - 1) = keep_rng.Cells(i, first_col).Resize(r, num_col) = arrNextIf del_empty Then  '删除空行j = (last_row - title_row) * r + title_row  '总行数For i = title_row + 1 To jbrr = .Cells(i, first_col).Resize(1, num_col)b = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(brr)), "")If Len(b) = 0 ThenIf del_rng Is Nothing ThenSet del_rng = .Rows(i)ElseSet del_rng = Union(del_rng, .Rows(i))End IfEnd IfNextIf Not del_rng Is Nothing Then del_rng.Delete  '删除行End If.Cells(1, first_col + num_col).Resize(1, resize_c - num_col).EntireColumn.Delete  '删除选中列End With
End Sub

转换结果

对本文图1（转换前不含7-20行），选中 B:M 列，运行代码得到如下图结果： D:M 列被删除

纵向转横向

使用自定义函数转换，具体说明见注释（key_col(0)为开始列号，之前的都为字典键，之后的都为待转换数据）

Function 纵向转横向(ByVal data_arr, ByVal key_col)  '按非key_col列为键横向合并数组'转换函数，arr为待转换数组（从1开始计数二维数组），key_col为列号数组（从0开始计数一维数组）'返回结果，从1开始计数二维数组；key_col(0)为开始列号，key_col(1)为结束列号，键在开始列号之前Dim dict As Object, num_col&, delimiter$, i&, j&, r&, c&, k$, max_c&, rr&, cc&If Not IsArray(data_arr) Or Not IsArray(key_col) Then Debug.Print "错误！参数都为数组": Exit FunctionSet dict = CreateObject("scripting.dictionary")num_col = key_col(1) - key_col(0) + 1: delimiter = Chr(28)  '分隔符ReDim res(1 To UBound(data_arr), 1 To UBound(data_arr) * num_col)For i = LBound(data_arr) To UBound(data_arr)k = ""For j = 1 To key_col(0) - 1k = k & delimiter & data_arr(i, j)NextIf Not dict.Exists(k) Thenr = r + 1: dict(k) = Array(r, key_col(0))For j = 1 To key_col(0) - 1res(r, j) = data_arr(i, j)NextElsec = dict(k)(1) + num_col: dict(k) = Array(dict(k)(0), c)max_c = WorksheetFunction.Max(max_c, c)  '最大列数End Ifrr = dict(k)(0): cc = dict(k)(1) - 1For j = key_col(0) To key_col(1)cc = cc + 1: res(rr, cc) = data_arr(i, j)NextNextReDim result(1 To r, 1 To max_c + num_col - 1)  '去除res数组多余部分For i = 1 To UBound(result)For j = 1 To UBound(result, 2)result(i, j) = res(i, j)NextNext纵向转横向 = result
End Function

转换结果

对“横向转纵向”无论是方法1还是方法2，生成的结果进行如下转换，生成的“纵向转横向”结果都一致，如下图

Sub 表格纵向转横向()Dim arr, brrarr = [a2:c20]: brr = 纵向转横向(arr, Array(2, 3))[d1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

多列键也可使用自定义函数转换，更具通用性

Sub 表格纵向转横向()Dim arr, brrarr = [a2:d20]: brr = 纵向转横向(arr, Array(3, 4))[f1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

附件：《Excel·VBA表格横向、纵向相互转换（附件）》

扩展阅读：
《excelhome-多列转3列》
《excel吧-3列转多列》