检查一行中的列是否被值占用，最大占用列限制为3

Question

我有复制对角线数据并将其粘贴在一行中的代码。 符合条件：

1. 限制 Paste Range 中的列，使其只能连续使用 3 列。
2. 根据 Copy Range 中的行数，Paste Range 中的行除以 Copy Range 中的 3。 如果 Copy Range 有 3 行，它将粘贴在 Paste Range 中的 1 行。 如果 Copy Range 有 6 行，它将在 Paste Range 等中粘贴到 2 行。
3. Paste Range中每一行的值的SUM/总和，不能超过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

这是代码结果：

但是，不幸的是这不是我想要的。 Paste Range 中的第一行和第二行完美地工作。但不知何故，当它在第三行循环时，它搞砸了。 我想要的是这样的东西。