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 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单元格区域行列数转换函数》（如需使用代码需复制）

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)为开始列号，之前的都为字典键，之后的都为待转换数据）

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，生成的结果进行如下转换，生成的“纵向转横向”结果都一致，如下图

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

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

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

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

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