Sub SplitDataAndSaveToNewWorkbooks Dim lastRow As Long Dim curRow As Long Dim sheetName As String Dim newWorkbook As Workbook Dim savePath As StringOn Error Resume Next 当代码运行错误时忽略继续向下运行

要实现每次运行时清除上一次的运行结果，可以在代码的开始部分添加清除操作。修改后的代码如下：

Sub SplitDataAndSaveToNewWorkbooks() Dim lastRow As Long Dim curRow As Long Dim sheetName As String Dim newWorkbook As Workbook Dim savePath As String

'清除上一次运行结果
On Error Resume Next
Application.DisplayAlerts = False
Kill ThisWorkbook.Path & "\SubTables\*.*"
Application.DisplayAlerts = True
On Error GoTo 0

'获取保存路径，这里为源数据表所在路径下的一个子文件夹"SubTables"
savePath = ThisWorkbook.Path & "\SubTables\"
If Dir(savePath, vbDirectory) = "" Then
    MkDir savePath
End If

With Worksheets("data") '修改为你的数据所在的Sheet名称
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row '修改为你的数据所在的列
    For curRow = 2 To lastRow '从第二行开始循环，第一行是标题
        sheetName = .Cells(curRow, "X").Value '以第X列作为分割列
        If Not SheetExists(sheetName) Then ' SheetExists 函数用来判断是否存在同名的Sheet
            Worksheets.Add After:=Worksheets(Worksheets.Count) '添加新的Sheet
            ActiveSheet.Name = sheetName '以分割列的值命名新的Sheet
        End If
        .Rows(1).Copy Destination:=Worksheets(sheetName).Rows(1)
        .Rows(curRow).Copy Destination:=Worksheets(sheetName).Rows(Worksheets(sheetName).Cells(Worksheets(sheetName).Rows.Count, "X").End(xlUp).Row + 1) '拷贝当前行到对应的Sheet
        Worksheets(sheetName).Columns.AutoFit '自适应单元格宽度
    Next
End With

For Each subTable In ThisWorkbook.Worksheets
    If subTable.Name <> "data" Then
        '判断是否为由"data"表拆分得到的子表
        Dim isSubTable As Boolean
        isSubTable = False
        For curRow = 2 To lastRow
            If subTable.Name = Worksheets("data").Cells(curRow, "X").Value Then
                isSubTable = True
                Exit For
            End If
        Next curRow
        '如果是"data"表拆分得到的子表，则保存到SubTables文件夹
        If isSubTable Then
            '拼接文件完整路径和文件名
            Dim filePath As String
            filePath = savePath & subTable.Name & ".xlsx"
            '如果文件已经存在，则删除旧文件
            If Dir(filePath) <> "" Then
                Kill filePath
            End If
            
            Set newWorkbook = Workbooks.Add
            subTable.UsedRange.Copy newWorkbook.Worksheets(1).UsedRange
            newWorkbook.Worksheets(1).Columns.AutoFit '自适应单元格宽度
            newWorkbook.SaveAs filePath
            newWorkbook.Close SaveChanges:=False
        End If
    End If
Next subTable

MsgBox "数据拆分完成并已保存到SubTables中！"

End Sub

Function SheetExists(shtName As String) As Boolean '判断Sheet是否存在 SheetExists = False For Each sht In ThisWorkbook.Sheets If sht.Name = shtName Then SheetExists = True Exit Function End If Next sht End Functio