VBA宏中While语句触发Application/Object定义错误（Error 1004）问题排查求助

我帮你梳理了代码里的几个核心问题，这就是导致你只创建一个工作表就触发Error 1004并停止的原因，下面是拆解和修正方案：

核心问题分析 #

• 重复创建同名工作表：你在While循环里每次都执行mainWB.Sheets.Add.Name = accHolder & "-" & randNumber，但randNumber是在Sub开头只生成一次的。当处理同一前缀的第二行数据时，会尝试创建和之前同名的工作表，Excel不允许同名工作表，直接触发1004错误。
• 死循环+提前终止：While循环里没有递增mainR，会一直卡在同一行；同时GoTo exitthis会直接跳出到循环外，导致整个遍历提前结束，根本没机会处理后续数据。
• 行号未重置：全局变量newR在处理完一个前缀的数据后没有重置为2，导致下一个工作表的写入行号会接着上一个的继续，不符合“每个工作表从第二行开始写入”的需求。

修正后的代码 #

Option Explicit
Public mainWB As Workbook
Public mainWS As Worksheet
Public newWS As Worksheet

Sub Main()
    Dim TranstactDate As Date, AmountExcl As Double, Account As String
    Dim mainR As Long, newR As Long
    Dim accHolder As String
    Dim uniquePrefixes As Collection
    Dim prefix As Variant
    
    ' 初始化基础变量
    Set uniquePrefixes = New Collection
    Set mainWB = Workbooks("arrears-formatter.xlsx")
    Set mainWS = mainWB.Worksheets("arrears-formatter")
    TranstactDate = mainWS.Cells(1, 2)
    
    ' 第一步：收集所有唯一的账号前缀（避免重复建表）
    On Error Resume Next ' 忽略重复添加的报错
    For mainR = 9 To mainWS.Cells(mainWS.Rows.Count, 1).End(xlUp).Row ' 只遍历有数据的行，不用硬写到100000
        If mainWS.Cells(mainR, 1) <> "" Then
            accHolder = Left(mainWS.Cells(mainR, 1), 3)
            uniquePrefixes.Add accHolder, Key:=accHolder ' Key确保前缀唯一
        End If
    Next mainR
    On Error GoTo 0 ' 恢复正常错误捕获
    
    ' 第二步：为每个唯一前缀创建工作表（先检查是否已存在）
    For Each prefix In uniquePrefixes
        ' 检查工作表是否存在，不存在则新建
        On Error Resume Next
        Set newWS = mainWB.Worksheets(prefix)
        On Error GoTo 0
        If newWS Is Nothing Then
            Set newWS = mainWB.Sheets.Add(After:=mainWB.Sheets(mainWB.Sheets.Count))
            newWS.Name = prefix ' 如果一定要加随机数，建议在这里生成专属随机数，避免重名
        End If
    Next prefix
    
    ' 第三步：遍历原始数据，写入对应工作表
    For mainR = 9 To mainWS.Cells(mainWS.Rows.Count, 1).End(xlUp).Row
        If mainWS.Cells(mainR, 1) = "" Then Exit For ' 遇到空行直接停止遍历
        
        accHolder = Left(mainWS.Cells(mainR, 1), 3)
        AmountExcl = mainWS.Cells(mainR, 3)
        Account = mainWS.Cells(mainR, 1)
        
        ' 获取当前前缀对应的工作表
        Set newWS = mainWB.Worksheets(accHolder)
        newR = newWS.Cells(newWS.Rows.Count, 1).End(xlUp).Row + 1 ' 找到工作表最后一行，从下一行开始写
        
        ' 批量写入数据到新工作表
        newWS.Cells(newR, 1) = TranstactDate
        newWS.Cells(newR, 2) = Account
        newWS.Cells(newR, 3) = "AR"
        newWS.Cells(newR, 4) = "Interest"
        newWS.Cells(newR, 5) = "0"
        newWS.Cells(newR, 6) = "7"
        newWS.Cells(newR, 7) = "Interest"
        newWS.Cells(newR, 8) = ""
        newWS.Cells(newR, 9) = AmountExcl
        newWS.Cells(newR, 10) = ""
        newWS.Cells(newR, 11) = ""
        newWS.Cells(newR, 12) = "0"
        newWS.Cells(newR, 13) = AmountExcl
        newWS.Cells(newR, 14) = "1"
        newWS.Cells(newR, 15) = AmountExcl
        newWS.Cells(newR, 16) = AmountExcl
        newWS.Cells(newR, 17) = "0"
        newWS.Cells(newR, 18) = "0"
        newWS.Cells(newR, 19) = ""
        newWS.Cells(newR, 20) = "0"
        newWS.Cells(newR, 21) = "0"
        newWS.Cells(newR, 22) = "0"
        newWS.Cells(newR, 23) = ""
        newWS.Cells(newR, 24) = ""
        newWS.Cells(newR, 25) = "0"
        newWS.Cells(newR, 26) = "0"
        newWS.Cells(newR, 27) = ""
        newWS.Cells(newR, 28) = "0"
        newWS.Cells(newR, 29) = "0"
        newWS.Cells(newR, 30) = "0"
        newWS.Cells(newR, 31) = "2750>050"
        newWS.Cells(newR, 32) = "0"
        newWS.Cells(newR, 33) = "0"
    Next mainR
End Sub

关键修改说明 #

1. 收集唯一前缀：用Collection存储不重复的账号前缀，避免重复创建工作表；同时只遍历有数据的行，大幅提升运行效率。
2. 安全创建工作表：先检查目标工作表是否存在，不存在再新建，彻底避免1004重名错误。如果一定要加随机数，建议在创建工作表时为每个前缀生成专属随机数。
3. 正确写入逻辑：每次写入前找到对应工作表的最后一行，从下一行开始写入，既不会覆盖已有数据，也不会出现行号混乱的问题。
4. 优化循环流程：移除了容易出错的GoTo和While循环，用标准的For循环控制遍历逻辑，避免提前终止或死循环。

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