我有复制对角线数据并将其粘贴在一行中的代码。 符合条件:
这是我当前的代码:
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 中的第一行和第二行完美地工作。但不知何故,当它在第三行循环时,它搞砸了。 我想要的是这样的东西。