求助：如何通过循环改造录制宏实现Excel批量行转列

Hey there! Let's revamp that macro to handle your bulk transposition task smoothly. Your original code only works for a single row, so we'll add a loop structure and optimize it to handle 10,000 rows of 1000-column email data efficiently—no more manual repetition!

First, let's fix the limitations of your original code: it relies on slow, unstable Select/Selection calls and only processes one row. Below is an optimized version with a loop that does the job in one go.

Optimized VBA Code #

Sub BulkTransposeEmails()
    Dim wsMaster As Worksheet
    Dim wsDest As Worksheet
    Dim totalRows As Long
    Dim currentRow As Long
    Dim destColumn As Long
    
    ' Speed up processing by disabling screen updates and events
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' Set direct references to your worksheets (avoids messy Select calls)
    Set wsMaster = ThisWorkbook.Sheets("Mastersheet")
    Set wsDest = ThisWorkbook.Sheets("Sheet2")
    
    ' Clear destination sheet first (optional—remove if you want to keep existing data)
    wsDest.Cells.Clear
    
    ' Define total rows to process (10,000 rows starting from row 2)
    totalRows = 10001 ' Rows 2 to 10001 = exactly 10,000 rows
    destColumn = 1 ' Start pasting in column A of Sheet2
    
    ' Loop through each row in Mastersheet
    For currentRow = 2 To totalRows
        ' Copy exactly 1000 columns starting from column J in the current row
        wsMaster.Range("J" & currentRow).Resize(1, 1000).Copy
        
        ' Paste transposed data into the destination column
        wsDest.Cells(1, destColumn).PasteSpecial Paste:=xlPasteAll, Transpose:=True
        
        ' Move to the next column for the next row's data
        destColumn = destColumn + 1
        
        ' Clear clipboard to free up memory and prevent lag
        Application.CutCopyMode = False
    Next currentRow
    
    ' Auto-adjust column widths for better readability
    wsDest.Columns.AutoFit
    
    ' Restore screen updates and events
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    MsgBox "Bulk transposition completed successfully!", vbInformation
End Sub

Key Improvements & Explanations #

• No more Select/Selection: We use worksheet variables (wsMaster, wsDest) to directly reference cells, which is faster and far more reliable for large datasets.
• Precise range selection: Resize(1, 1000) ensures we only copy exactly 1000 columns (instead of all columns up to XFD), cutting down on unnecessary processing.
• Automated loop: The For loop processes each of the 10,000 rows automatically—no manual input needed after clicking "Run".
• Performance boosts: Disabling screen updates and events eliminates lag caused by constant redrawing of the worksheet.
• Memory cleanup: Clearing the clipboard after each paste prevents memory bloat during long runs.

Alternative: Paste Transposed Data Vertically (Stacked) #

If you want each row's transposed data to stack vertically (instead of side-by-side in columns), modify the code like this:

Sub BulkTransposeVertical()
    Dim wsMaster As Worksheet
    Dim wsDest As Worksheet
    Dim totalRows As Long
    Dim currentRow As Long
    Dim destRow As Long
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set wsMaster = ThisWorkbook.Sheets("Mastersheet")
    Set wsDest = ThisWorkbook.Sheets("Sheet2")
    wsDest.Cells.Clear
    
    totalRows = 10001
    destRow = 1 ' Start pasting at row 1 of Sheet2
    
    For currentRow = 2 To totalRows
        wsMaster.Range("J" & currentRow).Resize(1, 1000).Copy
        wsDest.Cells(destRow, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
        
        ' Move down 1000 rows for the next set of transposed data
        destRow = destRow + 1000
        
        Application.CutCopyMode = False
    Next currentRow
    
    wsDest.Columns.AutoFit
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    MsgBox "Vertical bulk transposition done!", vbInformation
End Sub

Quick Notes #

• If Sheet2 doesn't exist in your workbook, add this code before setting wsDest to create it automatically:

  On Error Resume Next
  Set wsDest = ThisWorkbook.Sheets("Sheet2")
  On Error GoTo 0
  If wsDest Is Nothing Then Set wsDest = ThisWorkbook.Sheets.Add(After:=wsMaster): wsDest.Name = "Sheet2"
  

• For extra safety, you can add basic error handling to catch issues like insufficient memory during large runs.

内容的提问来源于stack exchange，提问作者ShakeelAhmad Mscit