Excel批量转置——录制会循环的宏

效果预览

实现过程

1.开发工具中选择相对引用，选择开始单元格（假设从1所在的单元格开始），点击录制宏；
2.使用鼠标选择数字1-10，复制，再选择数字1所在的单元格右侧第二个单元格处，右键转置粘贴。然后选择数字11-20，复制，选择数字11所在的单元格右侧第二个单元格处，右键转置粘贴。然后选择21-30，重复前面的操作（多重复几次，便于改VBA代码时找规律）。
3.选择列D-M，开始-查找-定位条件-空值-删除。
4.点击停止录制宏，开发工具-宏-编辑，编辑VBA代码。
5.刚刚操作录制的代码如下：

Sub Y()
'
' Y 宏
'
' 快捷键: Ctrl+Shift+W
'
    ActiveCell.Range("A1:A10").Select
    Selection.Copy
    ActiveCell.Offset(0, 2).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveCell.Offset(10, -2).Range("A1:A10").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveCell.Offset(0, 2).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveCell.Offset(10, -2).Range("A1:A10").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveCell.Offset(0, 2).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveWindow.SmallScroll Down:=-54
    ActiveCell.Columns("A:J").EntireColumn.Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
End Sub

6.找出重复的代码，用循环命令改写，并保存，改写后的代码如下：

Sub Y()
'
' Y 宏
'
' 快捷键: Ctrl+Shift+W
'
    ActiveCell.Range("A1:A10").Select
    Selection.Copy
    
     Do While ActiveCell <> ""
    ActiveCell.Offset(0, 2).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveCell.Offset(10, -2).Range("A1:A10").Select
    Application.CutCopyMode = False
    Selection.Copy
    Loop
    
    
    ActiveCell.Columns("A:M").EntireColumn.Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
End Sub