我有代码来复制对角线数据并将其粘贴在一行中。使用条件：
1.限制“粘贴范围”中的列，使其在一行中只能使用3列。
1.根据复制范围中的行数，粘贴范围中的行数除以复制范围中的3。如果复制范围有3行，则粘贴范围中的1行。如果复制范围有6行，则粘贴范围中的2行，依此类推。
1.“粘贴范围”中每一行中的值的SUM/total不能超过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

下面是代码结果：

但是，不幸的是，这不是我想要的。粘贴范围中的第一行和第二行工作得很好。但不知何故，当它在第三行循环时，它搞砸了。我想要的是这样的东西。