VBA宏运行时错误：按约2000行拆分文件且同邮箱行不拆分

Hey there! Let's figure out why your VBA macro is throwing a runtime error and get your row-splitting task working smoothly. Your goal is to split data into chunks around 2000 rows each, but keep all rows tied to the same AD email together—smart call, since splitting a user's data across files would be a major hassle.

First, let's cover the most likely reasons your current code is failing:

• Reliance on ActiveWorkbook (which can cause issues if another workbook is active by mistake)
• Missing or incorrectly implemented logic to check the AD column and extend chunks
• Not handling the final small chunk of data properly
• File path/naming issues causing permission or path errors

Here's a polished, error-resistant version of your macro with step-by-step comments to explain how it works:

Sub Chunkify_Data()
    Dim inputWs As Worksheet
    Dim lastRow As Long, startRow As Long, endRow As Long
    Dim newWorkbook As Workbook
    Dim currentEmail As String
    Dim chunkNumber As Integer
    
    ' Lock in the worksheet with your data (uses the workbook holding this macro)
    Set inputWs = ThisWorkbook.Worksheets(1)
    chunkNumber = 1
    startRow = 2 ' Assuming row 1 is your header row—adjust if needed
    
    ' Find the last row with data (checks column A; swap to your key data column if needed)
    lastRow = inputWs.Cells(inputWs.Rows.Count, "A").End(xlUp).Row
    
    ' Loop until we've processed all rows
    Do While startRow <= lastRow
        ' Start with a 2000-row chunk
        endRow = startRow + 1999
        
        ' If we're near the end, just set endRow to the last row
        If endRow > lastRow Then
            endRow = lastRow
        Else
            ' Grab the email from the initial end of the chunk
            currentEmail = inputWs.Cells(endRow, "AD").Value ' Replace "AD" with your actual email column if needed
            
            ' Extend the chunk until we hit a different email or the end of data
            Do While endRow < lastRow And inputWs.Cells(endRow + 1, "AD").Value = currentEmail
                endRow = endRow + 1
            Loop
        End If
        
        ' Create a brand new workbook for the chunk
        Set newWorkbook = Workbooks.Add
        
        ' Copy over the header row first
        inputWs.Rows(1).Copy Destination:=newWorkbook.Worksheets(1).Rows(1)
        ' Copy the current chunk of data
        inputWs.Rows(startRow & ":" & endRow).Copy Destination:=newWorkbook.Worksheets(1).Rows(2)
        
        ' Clean up the new workbook a bit
        newWorkbook.Worksheets(1).Columns.AutoFit
        
        ' Save the chunk (update the file path to match your needs!)
        newWorkbook.SaveAs Filename:="C:\Your\Target\Folder\Data_Chunk_" & chunkNumber & ".xlsx"
        ' Close the new workbook since we're done with it
        newWorkbook.Close SaveChanges:=False
        
        ' Move to the next set of rows
        startRow = endRow + 1
        chunkNumber = chunkNumber + 1
    Loop
    
    ' Let you know when it's done!
    MsgBox "Data split finished! Check your target folder for the chunks.", vbInformation
End Sub

What's Fixed & Why: #

• No more "active workbook" confusion: Using ThisWorkbook ensures we're always working with the file that has the macro, so you don't accidentally pull data from the wrong open workbook.
• Proper email grouping: After setting the initial 2000-row mark, we keep extending the chunk as long as the next row has the same email. This guarantees all rows for one user stay in the same file.
• Handles the final chunk: If there are fewer than 2000 rows left at the end, it just uses whatever's left instead of trying to copy non-existent rows.
• Clear variable names: Renamed things like startRow instead of srow so the code is easier to read and debug later.

Quick Troubleshooting: #

• "Subscript out of range" error: Double-check that your email is actually in column AD. If it's in column F, replace "AD" with "F" (or use the column number, like 6 for F).
• "Permission denied" when saving: Make sure the folder path you specified exists, and you have permission to save files there.
• Headers not copying: If your headers are in row 2 instead of row 1, change startRow = 2 to startRow = 3 and adjust the header copy line to inputWs.Rows(2).Copy....

Give this code a test run, and if you hit a specific error or need adjustments for your exact setup, just let me know!

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