基于邮箱地址创建新工作表的VBA宏异常问题求助

你的问题核心出在两点：

1. 非法/不可见字符导致工作表命名失败：部分邮箱可能包含Excel工作表名称禁用的字符（\/:*?"<>|），或是存在空格、换行符这类不可见控制字符。原代码里的On Error Resume Next会直接掩盖命名错误，让Excel自动创建默认名称的空工作表。
2. 循环逻辑存在缺陷：原循环会重复处理同一邮箱（未做去重），且通过判断r+1单元格为空来终止循环，可能漏掉最后一行有效数据。

Sub SplitByEmail()
    Dim wsSource As Worksheet
    Dim wsNew As Worksheet
    Dim lastRow As Long
    Dim email As String
    Dim cleanEmail As String
    Dim uniqueEmails As Object
    Dim cell As Range
    
    ' 初始化字典存储唯一邮箱
    Set uniqueEmails = CreateObject("Scripting.Dictionary")
    Set wsSource = ThisWorkbook.Sheets("InvoiceTracker")
    
    ' 清理D列无效格式，仅处理有数据的范围
    With wsSource.Range("D2:D" & wsSource.Cells(wsSource.Rows.Count, "D").End(xlUp).Row)
        .ClearFormats
        .ClearHyperlinks
        .ClearNotes
    End With
    
    ' 收集所有非空的唯一邮箱
    lastRow = wsSource.Cells(wsSource.Rows.Count, "D").End(xlUp).Row
    For Each cell In wsSource.Range("D2:D" & lastRow)
        email = Trim(cell.Value)
        If email <> "" And Not uniqueEmails.Exists(email) Then
            uniqueEmails.Add email, True
        End If
    Next cell
    
    ' 遍历唯一邮箱，创建工作表并复制对应数据
    For Each email In uniqueEmails.Keys
        ' 清理邮箱字符串，适配工作表命名规则
        cleanEmail = CleanSheetName(email)
        
        ' 检查目标工作表是否已存在
        On Error Resume Next
        Set wsNew = ThisWorkbook.Sheets(cleanEmail)
        On Error GoTo 0
        
        If wsNew Is Nothing Then
            ' 按邮箱筛选数据
            wsSource.Range("A1:AE1").AutoFilter Field:=4, Criteria1:=email
            
            ' 创建新工作表并设置属性
            Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            wsNew.Name = cleanEmail
            wsNew.Tab.Color = RGB(0, 112, 192)
            
            ' 复制可见数据到新表
            wsSource.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
                Destination:=wsNew.Range("A1")
            
            ' 取消筛选
            wsSource.ShowAllData
        End If
        
        Set wsNew = Nothing
    Next email
End Sub

' 辅助函数：清理字符串，移除Excel工作表名称不允许的字符
Function CleanSheetName(rawName As String) As String
    Dim invalidChars As Variant
    Dim char As Variant
    
    invalidChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    CleanSheetName = Trim(rawName)
    
    ' 移除非法字符
    For Each char In invalidChars
        CleanSheetName = Replace(CleanSheetName, char, "")
    Next char
    
    ' 移除控制字符（换行、制表符等）
    CleanSheetName = Replace(CleanSheetName, Chr(9), "")
    CleanSheetName = Replace(CleanSheetName, Chr(10), "")
    CleanSheetName = Replace(CleanSheetName, Chr(13), "")
    
    ' 限制长度为31字符（Excel工作表名称最大长度）
    If Len(CleanSheetName) > 31 Then
        CleanSheetName = Left(CleanSheetName, 31)
    End If
    
    ' 兜底避免空名称
    If CleanSheetName = "" Then
        CleanSheetName = "Sheet_" & Format(Now(), "YYYYMMDDHHMMSS")
    End If
End Function

• 去重处理：用字典收集唯一邮箱，避免重复创建相同工作表，同时提升运行效率。
• 非法字符清理：新增CleanSheetName函数，移除所有Excel禁用的工作表名称字符，同时清理不可见控制字符，解决命名失败的核心问题。
• 优化错误处理：仅在检查工作表是否存在时临时启用On Error Resume Next，避免掩盖其他代码错误。
• 精准数据范围：从D列最后一行倒推获取有效数据范围，避免处理大量空行。
• 无选择操作：全程用对象引用操作工作表，避免Select/Activate导致的不稳定问题。

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