如图：对图中区域 A1:M6 横向表格，转换成区域 A1:C20 纵向表格，即 B:M 列转换成每2列一组按行写入，并删除空行。同理，反向操作就是纵向表格转换成横向表格
目录
横向转纵向
实现方法1
对本文图1中，按"交期和交货数量"每5行2列为一组，依次按行写入，即按"交期"顺序排列
vbnet
Sub 表格横向转纵向1()
'分段转换，转换列之前同名不连续；不使用动态获取每行最后一列是考虑到部分选中拆分
Dim num_col&, title_row&, del_empty As Boolean, rng As Range, del_rng As Range
Dim 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 Sub
Set rng = Intersect(ActiveSheet.UsedRange, Selection) 'intersect语句避免选择整列造成无用计算
'选中区域开始列号，转换行数、列数
first_col = rng.column: resize_r = rng.Rows.Count - title_row: resize_c = rng.Columns.Count
If resize_c Mod num_col <> 0 Then Debug.Print "选中列数不可平分": Exit Sub
With ActiveSheet
keep_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_col
r = r + resize_r: .Cells(r, 1).Resize(resize_r, first_col - 1) = keep_rng
For j = 1 To num_col
brr = Application.index(arr, , i + j - 1) '按列拆分
.Cells(r, first_col + j - 1).Resize(resize_r, 1) = brr
Next
Next
If del_empty Then '删除空行
For i = title_row + 1 To r + resize_r
brr = .Cells(i, first_col).Resize(1, num_col)
b = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(brr)), "")
If Len(b) = 0 Then
If del_rng Is Nothing Then
Set del_rng = .Rows(i)
Else
Set del_rng = Union(del_rng, .Rows(i))
End If
End If
Next
If 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单元格区域行列数转换函数》（如需使用代码需复制）
vbnet
Sub 表格横向转纵向2()
'按行转换，转换列之前同名连续；不使用动态获取每行最后一列是考虑到部分选中拆分
Dim num_col&, title_row&, del_empty As Boolean, rng As Range, del_rng As Range
Dim 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 Sub
Set rng = Intersect(ActiveSheet.UsedRange, Selection) 'intersect语句避免选择整列造成无用计算
'选中区域开始列号、结束行号，转换行数、列数
first_col = rng.column: last_row = rng.Rows.Count
resize_r = rng.Rows.Count - title_row: resize_c = rng.Columns.Count: r = resize_c / num_col
If resize_c Mod num_col <> 0 Then Debug.Print "选中列数不可平分": Exit Sub
With ActiveSheet
For 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) = arr
Next
If del_empty Then '删除空行
j = (last_row - title_row) * r + title_row '总行数
For i = title_row + 1 To j
brr = .Cells(i, first_col).Resize(1, num_col)
b = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(brr)), "")
If Len(b) = 0 Then
If del_rng Is Nothing Then
Set del_rng = .Rows(i)
Else
Set del_rng = Union(del_rng, .Rows(i))
End If
End If
Next
If 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)为开始列号，之前的都为字典键，之后的都为待转换数据）
vbnet
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 Function
Set 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) - 1
k = k & delimiter & data_arr(i, j)
Next
If Not dict.Exists(k) Then
r = r + 1: dict(k) = Array(r, key_col(0))
For j = 1 To key_col(0) - 1
res(r, j) = data_arr(i, j)
Next
Else
c = dict(k)(1) + num_col: dict(k) = Array(dict(k)(0), c)
max_c = WorksheetFunction.Max(max_c, c) '最大列数
End If
rr = dict(k)(0): cc = dict(k)(1) - 1
For j = key_col(0) To key_col(1)
cc = cc + 1: res(rr, cc) = data_arr(i, j)
Next
Next
ReDim 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)
Next
Next
纵向转横向 = result
End Function转换结果
对"横向转纵向"无论是方法1还是方法2，生成的结果进行如下转换，生成的"纵向转横向"结果都一致，如下图
vbnet
Sub 表格纵向转横向()
Dim arr, brr
arr = [a2:c20]: brr = 纵向转横向(arr, Array(2, 3))
[d1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub
多列键也可使用自定义函数转换，更具通用性
vbnet
Sub 表格纵向转横向()
Dim arr, brr
arr = [a2:d20]: brr = 纵向转横向(arr, Array(3, 4))
[f1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub