三维换位（Microsoft Excel）

Sub Transpose3D()

Dim rngTbl As Range     Dim wsName As String     Dim R As Integer     Dim C As Integer     Dim i As Integer     Dim j As Integer     Dim Killit As Integer     Dim RCount As Integer     Dim CCount As Integer     Dim Table1() As Variant     Dim Row1() As Variant

RCount = Selection.Rows.Count     CCount = Selection.Columns.Count     If RCount < 2 Then         MsgBox ("Error; Select a range with more than one row.")

GoTo EndItAll     End If

wsName = ActiveSheet.Name     R = ActiveCell.Row     C = ActiveCell.Column

Set rngTbl = Selection     ReDim Table1(1 To RCount, 1 To CCount)

ReDim Row1(1 To 1, 1 To CCount)

Table1() = rngTbl.Value

On Error GoTo Abend

For i = 1 To RCount          If SheetExists(wsName & "_Row_" & i) Then             Killit = MsgBox("Sheet " & wsName & "_Row_" & i & _               " Already Exists!" & vbCrLf & _               "     Cancel: Stop Transposition" & vbCrLf & _               "     OK: Delete Sheet and Continue", vbOKCancel)

If Killit = vbCancel Then GoTo EndItAll             Application.DisplayAlerts = False             Sheets(wsName & "_Row_" & i).Delete             Application.DisplayAlerts = True         End If

Sheets.Add         ActiveSheet.Name = wsName & "_Row_" & i         Cells(R, C).Select         For j = 1 To CCount             Row1(1, j) = Table1(i, j)

Next j         Range(ActiveCell, ActiveCell.Offset(0, CCount - 1)) = Row1()

Sheets(wsName).Select     Next i     GoTo EndItAll

Abend:

MsgBox ("Error in Routine Transpose3D.")



EndItAll:

Application.DisplayAlerts = True End Sub

Function SheetExists(SheetName As String) As Boolean     Dim ws As Worksheet     SheetExists = False     For Each ws In ThisWorkbook.Worksheets         If ws.Name = SheetName Then             SheetExists = True             Exit For         End If     Next ws End Function