我来帮你搞定这个重复创建工作表的问题！核心问题应该是你的代码没提前校验目标工作表是否已经存在，所以每次遍历到相同值时都会反复创建（甚至可能触发Excel的同名工作表报错）。

下面是优化后的完整代码，我会逐段拆解关键逻辑：

Sub CreateUniqueSheetsFromColumnG()
    Dim wsSource As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim uniqueValues As Collection
    Dim value As Variant
    Dim wsNew As Worksheet
    
    ' 指定包含G列数据的源工作表（记得替换成你的实际表名）
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    Set uniqueValues = New Collection
    
    ' 获取G列最后一行的行号（避免遍历空单元格）
    lastRow = wsSource.Cells(wsSource.Rows.Count, "G").End(xlUp).Row
    
    ' 第一步：收集G列的所有唯一值
    On Error Resume Next ' 捕获重复值的添加错误，自动跳过重复项
    For Each cell In wsSource.Range("G2:G" & lastRow) ' 假设G1是表头，从G2开始遍历
        If cell.Value <> "" Then ' 跳过空单元格，避免创建无名称的工作表
            ' 用Key属性强制值唯一，重复时会报错，被On Error忽略
            uniqueValues.Add cell.Value, Key:=CStr(cell.Value)
        End If
    Next cell
    On Error GoTo 0 ' 恢复正常错误捕获
    
    ' 第二步：遍历唯一值，只创建不存在的工作表
    For Each value In uniqueValues
        ' 尝试引用同名工作表，判断是否已存在
        On Error Resume Next
        Set wsNew = ThisWorkbook.Worksheets(CStr(value))
        On Error GoTo 0
        
        ' 如果工作表不存在，就新建
        If wsNew Is Nothing Then
            Set wsNew = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            wsNew.Name = CStr(value)
            Set wsNew = Nothing ' 重置对象，准备下一次检查
        Else
            ' 可选：如果需要提示，可以在这里加日志或弹窗
            Debug.Print "工作表 """ & CStr(value) & """ 已存在，跳过创建"
        End If
    Next value
    
    MsgBox "处理完成！所有唯一值对应的工作表已创建（重复项已自动跳过）", vbInformation
End Sub

关键逻辑说明： #

• 用Collection收集唯一值：利用Collection的Key特性，强制每个值唯一，重复添加时会触发错误，通过On Error Resume Next自动忽略重复项，快速得到G列的唯一值集合。
• 提前检查工作表存在性：遍历每个唯一值时，先尝试引用同名工作表，如果引用失败（wsNew Is Nothing），说明工作表不存在，再执行创建操作。
• 处理特殊情况：跳过空单元格，避免创建无名称的无效工作表；如果G列值包含Excel不允许的字符（比如/ \ ? * [ ]），可以额外加字符替换逻辑：

  Dim cleanName As String
  cleanName = Replace(Replace(Replace(Replace(Replace(CStr(value), "/", "-"), "\", "-"), "?", "-"), "*", "-"), "[", "(")
  cleanName = Replace(cleanName, "]", ")")
  wsNew.Name = cleanName
  

• 可选扩展：如果需要把源表中对应行的数据复制到新工作表，可以在创建后添加筛选复制逻辑：

  ' 复制G列等于当前值的所有行到新表
  wsSource.Range("A1:Z" & lastRow).AutoFilter Field:=7, Criteria1:=value
  wsSource.Range("A1:Z" & lastRow).SpecialCells(xlCellTypeVisible).Copy wsNew.Range("A1")
  wsSource.AutoFilterMode = False ' 关闭筛选
  

这样修改后，你的代码就不会再重复创建工作表啦！

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