用于取消透视表的通用宏
您可以使用下一个宏来取消透视任何表:
Sub Unpivot()
Dim cws As Worksheet, vs As Long, cr As Long, cc As Long, i As Long, k As Long
Dim dr As Long, dc As Long, da As Long, ca As Variant, cb As Variant
Dim left As Long, right As Long, up As Long, down As Long
cr = ActiveCell.Row: cc = ActiveCell.Column
left = ActiveCell.End(xlToLeft).Column: up = ActiveCell.End(xlUp).Row
right = cc: While Not IsEmpty(Cells(cr, right + 1)): right = right + 1: Wend
down = cr: While Not IsEmpty(Cells(down + 1, cc)): down = down + 1: Wend
Set cws = ActiveSheet: ThisWorkbook.Sheets.Add: i = 1
cws.Range(cws.Cells(cr - 1, left), cws.Cells(cr - 1, cc - 1)).Copy
[A1].PasteSpecial xlPasteValues: dr = cr - up: dc = cc - left + 1
If dr > 1 Then
cws.Range(cws.Cells(up, cc - 1), cws.Cells(cr - 2, cc - 1)).Copy
Cells(1, dc).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
da = dc + dr: Cells(1, da - 1) = "TBD": Cells(1, da) = "Value"
k = 2: vs = right - cc + 1: dr = dr + 1
cb = WorksheetFunction.Transpose(cws.Cells(up, cc).Resize(cr - up, right - cc + 1))
For i = cr To down
ca = cws.Range(cws.Cells(i, left), cws.Cells(i, cc - 1))
Cells(k, 1).Resize(vs, dc - 1) = ca: Cells(k, dc).Resize(vs, dr) = cb
cws.Cells(i, cc).Resize(1, vs).Copy
Cells(k, da).PasteSpecial Paste:=xlPasteValues, Transpose:=True
k = k + vs
Next
End Sub
在表格中(它可以位于工作表上的任何位置,并且应受数据透视表单元格的行和列中的空单元格的限制),选择数据透视表单元格:
然后运行宏。结果表将在新工作表上创建:
源表可以包含任意数量的公共列和标题行: