无需VBScript实现Excel数据转置，超行容量时分表/分文件方案咨询

Great question! Handling large datasets that exceed Excel's row limits is a common pain point, and we can absolutely modify your existing macro to split the output across multiple worksheets or even separate workbooks when needed. Let's start by clarifying your source and expected output with formatted tables for clarity:

Source Data #

Expected Transposed Output #

Problem with Your Original Macro #

Your current macro works well for small datasets, but it will hit Excel's row limit (1,048,576 rows for Excel 2007+) when processing large source tables. We'll fix this by adding logic to automatically split output into new worksheets or workbooks when the current sheet reaches capacity, plus clean up some reliability issues in the original code.

Option 1: Split Across Multiple Worksheets (Same Workbook) #

This version creates new worksheets within the same source workbook whenever the current sheet is about to exceed Excel's row limit. We'll also replace fragile Select/ActiveSheet calls with explicit worksheet references for better stability.

Sub macro_generate_split_worksheets()
    Const MAX_EXCEL_ROWS As Long = 1048576 ' Excel 2007+ row limit
    Const ROW_BUFFER As Long = 100 ' Leave buffer to avoid overflow issues
    
    Dim maxRows As Long, maxCols As Long
    Dim data As Variant
    Dim path As String
    Dim openWb As Workbook
    Dim openWs As Worksheet
    Dim currentSht As Worksheet
    Dim writeRow As Long
    Dim col As Long, row As Long
    
    ' Open source workbook
    path = "D:\Informatica\9.6.1\server\infa_shared\NL_Power_Exposure\bespoke.xlsx"
    Set openWb = Workbooks.Open(path)
    Set openWs = openWb.Sheets("Sheet1")
    
    ' Get reliable source data dimensions (handles blank cells)
    maxRows = openWs.Cells(openWs.Rows.Count, 1).End(xlUp).Row
    maxCols = openWs.Cells(1, openWs.Columns.Count).End(xlToLeft).Column
    data = openWs.Range(openWs.Cells(1, 1), openWs.Cells(maxRows, maxCols)).Value
    
    ' Create first output worksheet
    Set currentSht = openWb.Sheets.Add(After:=openWb.Sheets(openWb.Sheets.Count))
    currentSht.Name = "Output_1"
    currentSht.Range("A:A").NumberFormat = "@" ' Set text format for IMPORTID
    
    ' Write header row
    With currentSht
        .Cells(1, 1).Value = "IMPORTID"
        .Cells(1, 2).Value = "DT"
        .Cells(1, 3).Value = "READING"
    End With
    writeRow = 2
    
    ' Iterate through columns and rows to transpose data
    For col = 2 To maxCols ' Start from column 2 (COLB in your source)
        For row = 2 To maxRows ' Start from row 2 (first data row)
            ' Check if current sheet is running out of rows
            If writeRow >= MAX_EXCEL_ROWS - ROW_BUFFER Then
                ' Create new output worksheet
                Set currentSht = openWb.Sheets.Add(After:=openWb.Sheets(openWb.Sheets.Count))
                currentSht.Name = "Output_" & openWb.Sheets.Count
                currentSht.Range("A:A").NumberFormat = "@"
                
                ' Re-write header to new sheet
                With currentSht
                    .Cells(1, 1).Value = "IMPORTID"
                    .Cells(1, 2).Value = "DT"
                    .Cells(1, 3).Value = "READING"
                End With
                writeRow = 2 ' Reset write row for new sheet
            End If
            
            ' Write transposed data to current sheet
            With currentSht
                .Cells(writeRow, 1).Value = data(1, col) ' IMPORTID (column header)
                .Cells(writeRow, 2).Value = data(row, 1) ' DT (COLA value)
                .Cells(writeRow, 3).Value = data(row, col) ' READING (cell value)
            End With
            writeRow = writeRow + 1
        Next row
    Next col
    
    ' Save and close the workbook
    openWb.Save
    openWb.Close
    MsgBox "Transposition complete! Output split across multiple worksheets.", vbInformation
End Sub

Key Improvements: #

• Row Limit Check: Uses MAX_EXCEL_ROWS with a buffer to trigger new sheet creation before hitting the limit.
• Reliable Data Range: Uses Rows.Count/Columns.Count to find the last row/column (avoids issues if there are blank cells in your source data).
• No Select/ActiveSheet: Uses explicit worksheet references to prevent bugs caused by accidental sheet switches.
• Auto-Named Sheets: New sheets are named Output_1, Output_2, etc., for easy identification.

Option 2: Split Across Separate Excel Workbooks #

If you prefer to split output into individual files (ideal for extremely large datasets), use this version. It creates new workbooks and saves them in the same directory as your source file.

Sub macro_generate_split_workbooks()
    Const MAX_EXCEL_ROWS As Long = 1048576
    Const ROW_BUFFER As Long = 100
    Dim maxRows As Long, maxCols As Long
    Dim data As Variant
    Dim sourcePath As String, outputDir As String
    Dim sourceWb As Workbook, outputWb As Workbook
    Dim sourceWs As Worksheet, outputWs As Worksheet
    Dim writeRow As Long
    Dim col As Long, row As Long
    Dim fileCounter As Long
    
    ' Open source workbook
    sourcePath = "D:\Informatica\9.6.1\server\infa_shared\NL_Power_Exposure\bespoke.xlsx"
    Set sourceWb = Workbooks.Open(sourcePath)
    Set sourceWs = sourceWb.Sheets("Sheet1")
    
    ' Get reliable source data dimensions
    maxRows = sourceWs.Cells(sourceWs.Rows.Count, 1).End(xlUp).Row
    maxCols = sourceWs.Cells(1, sourceWs.Columns.Count).End(xlToLeft).Column
    data = sourceWs.Range(sourceWs.Cells(1, 1), sourceWs.Cells(maxRows, maxCols)).Value
    
    ' Set output directory (same as source file)
    outputDir = Left(sourcePath, InStrRev(sourcePath, "\"))
    
    ' Create first output workbook
    fileCounter = 1
    Set outputWb = Workbooks.Add(xlWBATWorksheet) ' Create single-sheet workbook
    Set outputWs = outputWb.Sheets(1)
    outputWs.Name = "Output"
    outputWs.Range("A:A").NumberFormat = "@"
    
    ' Write header row
    With outputWs
        .Cells(1, 1).Value = "IMPORTID"
        .Cells(1, 2).Value = "DT"
        .Cells(1, 3).Value = "READING"
    End With
    writeRow = 2
    
    ' Iterate through columns and rows
    For col = 2 To maxCols
        For row = 2 To maxRows
            ' Check if current workbook is running out of rows
            If writeRow >= MAX_EXCEL_ROWS - ROW_BUFFER Then
                ' Save current output workbook
                outputWb.SaveAs Filename:=outputDir & "Transposed_Output_" & fileCounter & ".xlsx"
                outputWb.Close
                
                ' Create new output workbook
                fileCounter = fileCounter + 1
                Set outputWb = Workbooks.Add(xlWBATWorksheet)
                Set outputWs = outputWb.Sheets(1)
                outputWs.Name = "Output"
                outputWs.Range("A:A").NumberFormat = "@"
                
                ' Re-write header to new workbook
                With outputWs
                    .Cells(1, 1).Value = "IMPORTID"
                    .Cells(1, 2).Value = "DT"
                    .Cells(1, 3).Value = "READING"
                End With
                writeRow = 2
            End If
            
            ' Write transposed data
            With outputWs
                .Cells(writeRow, 1).Value = data(1, col)
                .Cells(writeRow, 2).Value = data(row, 1)
                .Cells(writeRow, 3).Value = data(row, col)
            End With
            writeRow = writeRow + 1
        Next row
    Next col
    
    ' Save the final output workbook
    outputWb.SaveAs Filename:=outputDir & "Transposed_Output_" & fileCounter & ".xlsx"
    outputWb.Close
    
    ' Close source workbook
    sourceWb.Save
    sourceWb.Close
    MsgBox "Transposition complete! Output split into " & fileCounter & " workbooks.", vbInformation
End Sub

Key Notes: #

• Output Directory: New workbooks are saved in the same folder as your source file, named Transposed_Output_1.xlsx, Transposed_Output_2.xlsx, etc.
• Single-Sheet Workbooks: Uses xlWBATWorksheet to create workbooks with only one sheet (avoids extra blank sheets).
• Final Save: Ensures the last workbook is saved after the loop finishes.

内容的提问来源于stack exchange，提问作者mohammed sheik dawood