Excel列行转置宏

Excel列行转置宏 Sub 列行转置() ' 宏由葛喜录编制 ' Excel格列数据转置为行数据 Dim s As Integer '转置后数据的起始行数 Dim i As Integer '欲转置数据的行(个)数 Dim k As Integer '转置后每行数据的个数 Dim a As Integer '转置后数据的行数 Dim x As Integer '转置后第一个数据所在的行数 Dim y As Integer '转置后第一个数据所在的列数 Dim z As Integer '欲转置数据的起始列数 Dim b As Integer '欲转置数据的起始行数 Dim newRange As Range Set newRange = Application.InputBox(prompt:="请选取欲转置数据所在区域:", Title:="选取数据区域", Type:=8) newRange.Select z = newRange.Row b = newRange.Column i = newRange.Rows.Count Set newRange = Application.InputBox(prompt:="请选取转置后第一行数据放置区 域:(注意:选取区域不能与原转置数据区域有重叠)", Title:="选取数据行区域", Type:=8) newRange.Select k = newRange.Columns.Count x = newRange.Row y = newRange.Column firstline: If b <= y + k - 1 And y <= b Then mybox = MsgBox("转置后数据区域与原数据区域有重叠，重试选取吗,“重试”重 新选取，“取消”退出", vbRetryCancel, "单元格选取错误") If mybox = vbRetry Then Set newRange = Application.InputBox(prompt:="请选取转置后第一个数据放置的单 元格:", Title:="选取放置单元格", Type:=8) newRange.Select k = newRange.Columns.Count x = newRange.Row y = newRange.Column GoTo firstline Else Exit Sub End If Else nextline: If i Mod k = 0 Then a = Int(i / k) Else a = Int(i / k) + 1 End If For s = 1 To a Application.DisplayAlerts = False Application.ScreenUpdating = False Range(Cells((k * (s - 1) + z), b), Cells(k * s + z - 1, b)).Select Selection.Copy Cells(s + x - 1, y).Select Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True Next s End If Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub