效果预览
VBA代码
Sub 转置并删除空格()
'
' 转置 宏
' 快捷键: Ctrl+Shift+U
' 设置屏幕不滚动
Application.ScreenUpdating = False
Range("B1").Select
ActiveCell.Range("A1:A6").Select
Do While ActiveCell <> ""
Selection.Copy
ActiveCell.Offset(0, 3).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveCell.Offset(6, -3).Range("A1:A6").Select
Application.CutCopyMode = False
Loop
Columns("E:J").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.Delete Shift:=xlUp
Range("E1:J1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1:A6").Select
Selection.Copy
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub