本文于2023年6月27日首发于本人同名公众号：Excel活学活用，更多文章案例请搜索关注！
☆本期内容概要☆
数据透视表转置单元格区域
公式法转置单元格区域
代码法转置单元格区域
大家好，我是冷水泡茶，今天有公众号粉丝咨询单元格转置方面的问题，把下图左边的表变成右边的形式：
他写了个VBA代码，反映说速度很慢，让我给参谋参谋。我开始以为是单元格区域转置，心想这还不简单，用数组嘛，甚至复制粘贴也行啊。但后来仔细一看，是有转置，但是只是把FILENAME横向展示，这可能要费点脑筋了。Anyway，我们还是先来聊一下通常意义下的转置吧，作个铺垫，他的需求我们放在后面再讲，一定要看到最后哦。
1、选择性粘贴法：选择需要转转置的区域，右击一个空白单元格，在弹出的菜单中点转置图标：
或者点击选择性粘贴，在弹出的对话框中勾选“转置”，再点确定。
2、数据透视表法：选中数据区域，插入-数据透视表，在数据透视表字段设置对话框中，把所有字段按顺序都拖到列，然后选中字段，右键，在弹出的菜单中选择重复项目标签，基本能达到一个转置的效果。
3、公式法：在右边的空白单元格，输入公式，往下复制、往右复制。
=OFFSET($A$1,COLUMN(A1)-1,ROW(A1)-1)
4、VBA代码法：
（1）数组法
Sub transfrom() Dim arr(), arrTem(), iRow As Integer, iCol As Integer Dim ws As Worksheet Set ws = Sheets("Sheet1") ws.Activate With ws iRow = .UsedRange.Rows.Count iCol = .UsedRange.Columns.Count arr = .Range(Cells(1, 1), Cells(iRow, iCol)).Value End With '*************************************** '也可以不用通过中间数组，直接用工作表函数transpose ReDim arrTem(1 To iCol, 1 To iRow) For i = 1 To iRow For j = 1 To iCol arrTem(j, i) = arr(i, j) Next Next '************************************** Sheets("VBA").Cells.Clear Sheets("VBA").Range("A1").Resize(iCol, iRow) = arrTem 'Sheets("VBA").Range("A1").Resize(iCol, iRow) = Application.WorksheetFunction.Transpose(arr)End Sub
（2）用代码选择性粘贴法：
Sub transform2() Dim iRow As Integer, iCol As Integer Dim ws As Worksheet Dim SourceRng As Range Dim TargetRng As Range Set ws = Sheets("Sheet1") With ws .Activate iRow = .UsedRange.Rows.Count iCol = .UsedRange.Columns.Count Set SourceRng = .Range(Cells(1, 1), Cells(iRow, iCol)) End With Set ws = Sheets("VBA") With ws .Cells.Clear Set TargetRng = .Range("A1") End With SourceRng.Copy TargetRng.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True '清除剪贴板中的内容 Application.CutCopyMode = FalseEnd Sub
回到我们粉丝提出的特殊情况转置，我经过观察数据，给出的方案是使用数据透视表，确定能行，问题解决。
如果一定要用代码来做呢，也是可以的（今天的核心内容）：
Sub transform3() Dim arr(), arrTem() Dim iRow As Integer, iCol As Integer Dim newRow As Integer, newCol As Integer Dim arrResult() Dim ws As Worksheet Dim dic As Variant Set ws = Sheets("Sheet1") Set dic = CreateObject("Scripting.Dictionary") dic("FILENAME") = 1 With ws .Activate iRow = .UsedRange.Rows.Count iCol = .UsedRange.Columns.Count arr = .Range(Cells(1, 1), Cells(iRow, iCol)).Value End With ReDim arrTem(1 To iCol, 1 To iRow) For i = 1 To iRow dic(arr(i, 3)) = 1 Next arrTem = dic.KEYS newRow = UBound(arrTem) ReDim arrResult(0 To newRow, 0 To 0) For i = 0 To newRow arrResult(i, 0) = arrTem(i) Next For i = 2 To iRow If (i - 2) Mod 10 = 0 Then newCol = UBound(arrResult, 2) ReDim Preserve arrResult(0 To newRow, 0 To newCol + 2) End If For j = 0 To newRow If arr(i, 3) = arrResult(j, 0) Then arrResult(0, newCol + 1) = arr(i, 2) arrResult(0, newCol + 2) = arr(i, 2) arrResult(1, newCol + 1) = "X" arrResult(1, newCol + 2) = "Y" arrResult(j, newCol + 1) = arr(i, 4) arrResult(j, newCol + 2) = arr(i, 5) End If Next Next Sheets("特殊需求（VBA）").Cells.Clear Sheets("特殊需求（VBA）").Range("A1").Resize(UBound(arrResult, 1) + 1, UBound(arrResult, 2) + 1) = arrResultEnd Sub
代码解析：
（1）把数据装入数组arr
（2）把关键字LOCATION装入字典，在这之前先加入一条记录FILENAME。
（3）把字典的key赋值给arrtem，再重定义arrResult为二维数组，把数组arrTem的值再存到数组arrResult。二维数组可以动态扩展列。
（4）循环数组arr，将其第三列与arrResult的第一列进行比较，相同的则写入arrResult
（5）判断i的值，如果（i-2）除以10正好整除，说明需要把数组再增加两列了（字典中的关键字LOCATION，共有10条记录），这几句代码是整个代码的核心灵魂所在：
If (i - 2) Mod 10 = 0 Then newCol = UBound(arrResult, 2) ReDim Preserve arrResult(0 To newRow, 0 To newCol + 2)End If
好，今天就到这吧。欢迎点赞、留言、分享，谢谢大家，我们下期再会。
☆往期合集☆【2023年3月】【2023年4月】【2023年5月】