咨询Excel循环复制Sheet1指定区域并转置粘贴到Sheet2的逻辑

我明白你搞不清这个循环的逻辑，其实核心就是控制两个变量：Sheet1中复制区域的起始列，以及Sheet2中粘贴区域的起始行，每次循环让这两个变量按规则递增就行。直接给你写好代码，再一步步解释：

完整VBA代码 #

Sub TransposePasteLoop()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim startCol As Integer ' 初始复制列（J列是第10列）
    Dim pasteRow As Integer ' 初始粘贴行
    Dim i As Integer ' 循环计数器
    Dim loopTimes As Integer ' 需要循环的次数，你可以根据需求修改
    
    ' 绑定工作表对象，避免用ActiveSheet导致出错
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    
    ' 初始化参数
    startCol = 10 ' J列的列号是10
    pasteRow = 1 ' 第一次粘贴从第1行开始
    loopTimes = 10 ' 假设你需要循环10次，可自行调整
    
    ' 开始循环
    For i = 0 To loopTimes - 1
        ' 复制Sheet1中指定区域：从第6行、第(startCol+i)列开始，100行16列
        ws1.Cells(6, startCol + i).Resize(100, 16).Copy
        
        ' 转置粘贴到Sheet2的指定位置：从pasteRow行、第2列（B列）开始
        ws2.Cells(pasteRow, 2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
        
        ' 更新下一次粘贴的起始行：每次间隔18行
        pasteRow = pasteRow + 18
    Next i
    
    ' 清除剪贴板，避免弹窗提示
    Application.CutCopyMode = False
End Sub

关键逻辑拆解 #

• 复制区域的控制：
  初始复制列是J列（对应列号10），每次循环i加1，起始列就变成10+1=11（K列）、10+2=12（L列），以此类推，完美匹配你“每次右移一列”的需求。Resize(100,16)就是固定选取100行16列的区域。

• 粘贴位置的控制：
  第一次粘贴从第1行开始，每次循环后粘贴行加18，也就是1→19→37→...，刚好满足“每次粘贴位置间隔18行”的要求。

• 转置粘贴：
  用PasteSpecial Transpose:=True实现转置，把100行16列的区域变成16行100列，正好对应Sheet2中B1:CW16这类的区域（B到CW刚好是100列）。

注意事项 #

1. 如果你不确定需要循环多少次，可以根据Sheet1的实际列数自动计算，比如把loopTimes改成：

   loopTimes = ws1.Cells(6, ws1.Columns.Count).End(xlToLeft).Column - startCol + 1
   

   这样会自动从J列开始，一直处理到第6行最后一个有数据的列。
2. 确保Sheet1和Sheet2存在，不然代码会报错。
3. 运行前最好保存文件，避免意外丢失数据。

内容的提问来源于stack exchange，提问作者newtoVBA