如圖：對圖中區(qū)域 A1:M6 橫向表格，轉(zhuǎn)換成區(qū)域 A1:C20 縱向表格，即 B:M 列轉(zhuǎn)換成每2列一組按行寫入，并刪除空行。同理，反向操作就是縱向表格轉(zhuǎn)換成橫向表格
橫向轉(zhuǎn)縱向
實現(xiàn)方法1
對本文圖1中，按“交期和交貨數(shù)量”每5行2列為一組，依次按行寫入，即按“交期”順序排列
Sub 表格橫向轉(zhuǎn)縱向1()
'分段轉(zhuǎn)換，轉(zhuǎn)換列之前同名不連續(xù)；不使用動態(tài)獲取每行最后一列是考慮到部分選中拆分
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&
'--------------------參數(shù)填寫：num_col、title_row都為數(shù)字，選中后才可運行代碼
num_col = 2 '需要拆分的數(shù)據(jù)每行固定的列數(shù)
title_row = 1 '表頭行數(shù)
del_empty = True '是否刪除空行
If Selection.Count = 1 Then Debug.Print "未選中列，無法運行代碼": Exit Sub
Set rng = Intersect(ActiveSheet.UsedRange, Selection) 'intersect語句避免選擇整列造成無用計算
'選中區(qū)域開始列號，轉(zhuǎn)換行數(shù)、列數(shù)
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 "選中列數(shù)不可平分": Exit Sub
With ActiveSheet
keep_rng = .Cells(title_row + 1, 1).Resize(resize_r, first_col - 1) '不變區(qū)域
arr = .Cells(title_row + 1, first_col).Resize(resize_r, resize_c) '轉(zhuǎn)換區(qū)域
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)
If num_col > 1 Then 'brr是否為數(shù)組
b = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(brr)), "")
ElseIf num_col = 1 Then
b = brr
End If
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
轉(zhuǎn)換結(jié)果
對本文圖1（轉(zhuǎn)換前不含7-20行），選中 B:M 列，運行代碼得到如下圖結(jié)果： D:M 列被刪除
實現(xiàn)方法2
對本文圖1中，按“產(chǎn)品規(guī)格”每個產(chǎn)品后面6組“交期和交貨數(shù)量”轉(zhuǎn)換為每6行2列，依次按行寫入，即按“產(chǎn)品”順序排列
以下代碼使用了數(shù)組行列數(shù)轉(zhuǎn)換函數(shù)，調(diào)用了wraparr函數(shù)，代碼詳見《Excel·VBA單元格區(qū)域行列數(shù)轉(zhuǎn)換函數(shù)》（如需使用代碼需復(fù)制）
Sub 表格橫向轉(zhuǎn)縱向2()
'按行轉(zhuǎn)換，轉(zhuǎn)換列之前同名連續(xù)；不使用動態(tài)獲取每行最后一列是考慮到部分選中拆分
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&
'--------------------參數(shù)填寫：num_col、title_row都為數(shù)字，選中后才可運行代碼
num_col = 2 '需要拆分的數(shù)據(jù)每行固定的列數(shù)
title_row = 1 '表頭行數(shù)
del_empty = True '是否刪除空行
If Selection.Count = 1 Then Debug.Print "未選中列，無法運行代碼": Exit Sub
Set rng = Intersect(ActiveSheet.UsedRange, Selection) 'intersect語句避免選擇整列造成無用計算
'選中區(qū)域開始列號、結(jié)束行號，轉(zhuǎn)換行數(shù)、列數(shù)
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 "選中列數(shù)不可平分": Exit Sub
With ActiveSheet
For i = last_row To title_row + 1 Step -1 '倒序循環(huán)
keep_rng = .Cells(i, 1).Resize(1, first_col - 1) '不變區(qū)域
arr = .Cells(i, first_col).Resize(1, resize_c) '轉(zhuǎn)換區(qū)域
arr = wraparr(arr, "row", r) '調(diào)用函數(shù)將arr轉(zhuǎn)換為r行num_col的數(shù)組
.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 '總行數(shù)
For i = title_row + 1 To j
brr = .Cells(i, first_col).Resize(1, num_col)
If num_col > 1 Then 'brr是否為數(shù)組
b = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(brr)), "")
ElseIf num_col = 1 Then
b = brr
End If
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
轉(zhuǎn)換結(jié)果
對本文圖1（轉(zhuǎn)換前不含7-20行），選中 B:M 列，運行代碼得到如下圖結(jié)果： D:M 列被刪除
縱向轉(zhuǎn)橫向
使用自定義函數(shù)轉(zhuǎn)換，具體說明見注釋（key_col(0)為開始列號，之前的都為字典鍵，之后的都為待轉(zhuǎn)換數(shù)據(jù)）
Function 縱向轉(zhuǎn)橫向(ByVal data_arr, ByVal key_col) '按非key_col列為鍵橫向合并數(shù)組
'轉(zhuǎn)換函數(shù)，arr為待轉(zhuǎn)換數(shù)組（從1開始計數(shù)二維數(shù)組），key_col為列號數(shù)組（從0開始計數(shù)一維數(shù)組）
'返回結(jié)果，從1開始計數(shù)二維數(shù)組；key_col(0)為開始列號，key_col(1)為結(jié)束列號，鍵在開始列號之前
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 "錯誤！參數(shù)都為數(shù)組": 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) '最大列數(shù)
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數(shù)組多余部分
For i = 1 To UBound(result)
For j = 1 To UBound(result, 2)
result(i, j) = res(i, j)
Next
Next
縱向轉(zhuǎn)橫向 = result
End Function
轉(zhuǎn)換結(jié)果
對“橫向轉(zhuǎn)縱向”無論是方法1還是方法2，生成的結(jié)果進行如下轉(zhuǎn)換，生成的“縱向轉(zhuǎn)橫向”結(jié)果都一致，如下圖
Sub 表格縱向轉(zhuǎn)橫向()
Dim arr, brr
arr = [a2:c20]: brr = 縱向轉(zhuǎn)橫向(arr, Array(2, 3))
[d1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub
多列鍵也可使用自定義函數(shù)轉(zhuǎn)換，更具通用性
Sub 表格縱向轉(zhuǎn)橫向()
Dim arr, brr
arr = [a2:d20]: brr = 縱向轉(zhuǎn)橫向(arr, Array(3, 4))
[f1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub
附件：《Excel·VBA表格橫向、縱向相互轉(zhuǎn)換（附件）》文章來源：http://www.zghlxwxcb.cn/news/detail-624980.html
擴展閱讀：
《excelhome-多列轉(zhuǎn)3列》
《excel吧-3列轉(zhuǎn)多列》文章來源地址http://www.zghlxwxcb.cn/news/detail-624980.html
到了這里，關(guān)于Excel·VBA表格橫向、縱向相互轉(zhuǎn)換的文章就介紹完了。如果您還想了解更多內(nèi)容，請在右上角搜索TOY模板網(wǎng)以前的文章或繼續(xù)瀏覽下面的相關(guān)文章，希望大家以后多多支持TOY模板網(wǎng)！
