VBA代码问题：对角线数据转置粘贴不符合预期，求修正

需求说明 #

• 粘贴区域每行仅限使用3列
• 粘贴区域行数 = 复制区域行数 ÷ 3（例：复制区域3行→粘贴区域1行，6行→2行）
• 粘贴区域每行数值总和不得超过30

问题现状 #

现有代码运行后，粘贴区域前两行符合预期，但第三行数据错乱，无法达到目标效果。

现有代码 #

Option Explicit

Sub TransposeDiagonalData()
    Dim copyRange As Range
    Dim pasteRange As Range
    ' Set copyRange to the range of diagonal data
    Set copyRange = Range("A1:I9")
    ' Determine the number of columns in the copyRange
    Dim numCols As Integer
    numCols = copyRange.Columns.Count
    ' Determine the number of rows needed in the pasteRange
    Dim numRows As Integer
    numRows = numCols / 3
    ' Set pasteRange to start at A10 and have a maximum of 3 columns
    Set pasteRange = Range("A10").Resize(numRows, 3)
    ' Loop through each column of the copyRange
    Dim copyCol As Range
    For Each copyCol In copyRange.Columns
        ' Loop through each cell in the current column of the copyRange
        Dim copyCell As Range
        For Each copyCell In copyCol.Cells
            ' Check if the current cell in the copyRange has data
            If Not IsEmpty(copyCell.Value) Then
                ' Determine the next available row in the current column of the pasteRange
                Dim nextRow As Integer
                nextRow = GetNextAvailableRow(copyCol.Column, pasteRange)
                ' Check if the first row in the pasteRange has fewer than 3 occupied cells
                If WorksheetFunction.CountA(pasteRange.Rows(1)) < 3 Then
                    ' Copy the data from the current cell in the copyRange and paste it into the first available row of the pasteRange
                    pasteRange.Cells(nextRow, WorksheetFunction.CountA(pasteRange.Rows(nextRow)) + 1).Value = copyCell.Value
                    ' Check if the second row in the pasteRange has fewer than 3 occupied cells
                ElseIf WorksheetFunction.CountA(pasteRange.Rows(2)) < 3 Then
                    'Copy the data from the current cell in the copyRange and paste it into the second available row of the pasteRange
                    'pasteRange.Cells(nextRow + 1, WorksheetFunction.CountA(pasteRange.Rows(nextRow + 2)) + 1).Value = copyCell.Value
                    pasteRange.Cells(nextRow + 1, copyCol.Column - copyRange.Column + 1).Value = copyCell.Value
                ' Check if the third row in the pasteRange has fewer than 3 occupied cells
                Else
                    'WorksheetFunction.CountA(pasteRange.Rows(3)) < 3 Then
                    ' Copy the data from the current cell in the copyRange and paste it into the third available row of the pasteRange
                    'pasteRange.Cells(nextRow + 2, WorksheetFunction.CountA(pasteRange.Rows(nextRow + 2)) + 1).Value = copyCell.Value
                    pasteRange.Cells(nextRow + 2, copyCol.Column - copyRange.Column + 2).Value = copyCell.Value
                End If
            End If
        Next copyCell
    Next copyCol
End Sub

Function GetNextAvailableRow(colNum As Integer, pasteRange As Range) As Integer
    'Determine the last occupied row in the current column of the pasteRange
    Dim lastRow As Range
    Set lastRow = pasteRange.Columns(colNum - pasteRange.Column + 1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    'Check if any data was found in the column
    If lastRow Is Nothing Then
        'If no data was found, return the first row of the column in the pasteRange
        GetNextAvailableRow = 1
    Else
        'If data was found, return the next available row in the column of the pasteRange
        GetNextAvailableRow = lastRow.Row + 1
    End If
End Function

当前运行效果 #

期望效果 #

修正方案及代码 #

原代码核心问题在于行填充逻辑混乱、列索引计算错误，且未严格执行每行总和不超过30的限制。以下是修正后的代码：

Option Explicit

Sub TransposeDiagonalData()
    Dim copyRange As Range
    Dim pasteRange As Range
    Dim numRowsPaste As Integer
    Dim currentPasteRow As Integer
    Dim currentColInRow As Integer
    Dim currentSum As Double
    
    ' 设置复制区域和粘贴起始位置
    Set copyRange = Range("A1:I9")
    numRowsPaste = copyRange.Rows.Count / 3 ' 粘贴区域行数
    Set pasteRange = Range("A10").Resize(numRowsPaste, 3)
    
    ' 清空粘贴区域原有数据
    pasteRange.ClearContents
    
    currentPasteRow = 1
    currentColInRow = 1
    
    ' 遍历复制区域的对角线数据（A1、B2、C3...I9）
    Dim i As Integer
    For i = 1 To copyRange.Rows.Count
        Dim cellValue As Double
        cellValue = copyRange.Cells(i, i).Value
        
        ' 跳过空值
        If IsEmpty(cellValue) Then GoTo NextCell
        
        ' 检查当前行是否已满，或添加后总和超30则切换到下一行
        currentSum = WorksheetFunction.Sum(pasteRange.Rows(currentPasteRow))
        If currentColInRow > 3 Or (currentSum + cellValue > 30 And currentSum > 0) Then
            currentPasteRow = currentPasteRow + 1
            currentColInRow = 1
            ' 若已超出粘贴区域行数，停止循环
            If currentPasteRow > numRowsPaste Then Exit For
            currentSum = 0
        End If
        
        ' 写入数据
        pasteRange.Cells(currentPasteRow, currentColInRow).Value = cellValue
        currentColInRow = currentColInRow + 1
        
NextCell:
    Next i
End Sub

修正说明 #

1. 直接遍历复制区域的对角线单元格，避免原代码遍历所有列和单元格的冗余操作
2. 跟踪当前粘贴行和列，优先填满一行再切换到下一行，逻辑更清晰
3. 增加每行总和检查，确保添加新数据后总和不超过30，若超则自动切换到下一行
4. 清空粘贴区域原有数据，避免残留旧值影响结果
5. 移除逻辑混乱的GetNextAvailableRow函数，简化代码结构

内容的提问来源于stack exchange，提问作者The Flying Javamen