求助：VBA实现复制转置粘贴且每粘贴后跳过一列

Hey Thomas, I’ve dealt with exactly this kind of transpose-and-skipping scenario before—let’s get your issue sorted out. From what you described, you need to take rows of source data, transpose each into a column in another sheet, and leave an empty column between each transposed set. Here’s a solid VBA solution that fixes the column-skipping logic and handles common edge cases:

Step-by-Step Solution Code #

Sub TransposeRowsWithSkippedColumns()
    ' Define worksheet objects
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim sourceRow As Range
    Dim targetColumn As Integer
    Dim lastSourceRow As Long
    Dim currentRow As Long
    
    ' Set your actual sheet names here
    Set sourceSheet = ThisWorkbook.Worksheets("SourceData")
    Set targetSheet = ThisWorkbook.Worksheets("TransposedData")
    
    ' Initialize starting column in target sheet
    targetColumn = 1
    ' Get the last row with data in source sheet (adjust column if needed)
    lastSourceRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
    
    ' Loop through each row in source data
    For currentRow = 1 To lastSourceRow
        ' Grab only the populated cells in the current source row
        Set sourceRow = sourceSheet.Range(sourceSheet.Cells(currentRow, 1), _
                                         sourceSheet.Cells(currentRow, sourceSheet.Columns.Count).End(xlToLeft))
        
        ' Transpose and paste to target column
        sourceRow.Copy
        targetSheet.Cells(1, targetColumn).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Transpose:=True
        
        ' Skip the next column by incrementing by 2
        targetColumn = targetColumn + 2
        ' Clear copy mode to avoid clipboard bloat
        Application.CutCopyMode = False
    Next currentRow
    
    ' Optional: Auto-fit target columns for readability
    targetSheet.Columns.AutoFit
    MsgBox "Transpose completed successfully!", vbExclamation
End Sub

Key Customization Tips #

• Worksheet Names: Replace "SourceData" and "TransposedData" with your actual sheet labels.
• Source Row Range: If your source rows only use specific columns (e.g., A to F), adjust the sourceRow range to sourceSheet.Range("A" & currentRow & ":F" & currentRow) instead of the dynamic end-of-row check.
• Paste Type: Change xlPasteValuesAndNumberFormats to xlPasteAll if you need to copy formulas and formatting too.

Fixes for Common Existing Code Issues #

If your current code had problems like:

• Wrong Column Skipping: The targetColumn = targetColumn + 2 ensures we always leave one empty column between transposed sets.
• Empty Cells Cluttering Transpose: The dynamic End(xlToLeft) ensures we only copy cells with data from each source row, avoiding blank rows in the transposed columns.
• Clipboard Memory Issues: Application.CutCopyMode = False clears the clipboard after each paste to prevent slowdowns with large datasets.

Just drop this code into your VBA editor (Alt + F11), tweak the sheet names to match your workbook, and run it—this should replicate your manual fill expected behavior perfectly.

内容的提问来源于stack exchange，提问作者Thomas de Ruiter