如何在VBA中循环执行TRANSPOSE公式并递增单元格范围？

我来帮你搞定这个循环递增的事儿！你现在的问题是单次宏能正常执行，但没法让目标范围和转置范围同步往下挪，对吧？其实核心就是在循环里动态更新行号就行，我给你两种实用方案，按需选择：

方案1：固定循环次数（适合已知要处理多少行的场景） #

直接用For循环，指定起始和结束的目标行，每次循环让行号自动加1，同步更新两个范围：

Sub TransposeLoop()
    Dim startRow As Integer
    Dim endRow As Integer
    Dim i As Integer
    
    ' 这里设置你的起始目标行和结束目标行，比如从第9行到第20行
    startRow = 9
    endRow = 20
    
    For i = startRow To endRow
        ' 目标范围：D列到F列的第i行
        Dim targetRange As Range
        Set targetRange = Range("D" & i & ":F" & i)
        
        ' 转置范围：E列，从i+6行到i+8行（对应你第一次的R[6]C[5]:R[8]C[5]）
        Dim transposeRange As Range
        Set transposeRange = Range("E" & (i + 6) & ":E" & (i + 8))
        
        ' 直接写入数组公式，不用Select，效率更高更稳定
        targetRange.FormulaArray = "=TRANSPOSE(" & transposeRange.Address(True, True, xlR1C1) & ")"
    Next i
End Sub

方案2：动态判断终止（适合不知道要处理多少行，直到转置范围无数据为止） #

如果你的数据行数不固定，可以用Do While循环，检查转置范围的第一行是否有数据，无数据就停止循环：

Sub TransposeLoopDynamic()
    Dim currentRow As Integer
    currentRow = 9 ' 起始目标行
    
    ' 检查转置范围的第一行（E列，currentRow+6行）是否有值，没有就停止循环
    Do While Range("E" & (currentRow + 6)).Value <> ""
        Dim targetRange As Range
        Set targetRange = Range("D" & currentRow & ":F" & currentRow)
        
        Dim transposeRange As Range
        Set transposeRange = Range("E" & (currentRow + 6) & ":E" & (currentRow + 8))
        
        targetRange.FormulaArray = "=TRANSPOSE(" & transposeRange.Address(True, True, xlR1C1) & ")"
        
        ' 行号加1，下一次循环处理下一行
        currentRow = currentRow + 1
    Loop
End Sub

为啥你之前的Do While没成功？ #

大概率是没正确更新行号，或者终止条件设置不合理。另外建议尽量别用Select操作，直接操作Range对象不仅执行效率更高，还不容易因为选区变化出现意外问题。

你可以根据自己的实际数据调整列号（比如转置的列不是E就改成对应列）、起始行这些参数，应该就能完美跑起来啦！

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