Excel VBA数据拆分：自动清除上一次运行结果并保存到新工作簿

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 Function

代码功能：

清除上一次运行结果: 在代码开始部分添加了清除操作，使用Kill命令删除SubTables文件夹下的所有文件，确保每次运行都能够从干净的环境开始。
数据拆分: 根据指定列的值（代码中为第X列）将源数据表拆分成多个新的工作簿。
保存到新工作簿: 将每个拆分后的工作簿保存到SubTables文件夹中，并以对应列的值作为文件名。
自适应单元格宽度: 代码包含了自适应单元格宽度的功能，确保所有数据都能够完整显示。

使用方法：

将代码复制到您的Excel工作簿的VBA编辑器中。
将代码中的'data'修改为您的源数据所在的Sheet名称。
将代码中的'X'修改为用于拆分的列号。
运行代码，数据将被拆分并保存到'SubTables'文件夹中。

注意：

'SubTables'文件夹必须位于您的源数据表所在路径下。
运行代码之前，请确保'SubTables'文件夹中没有重要文件，因为代码会删除文件夹内的所有文件。
代码默认从第二行开始循环拆分数据，如果您的数据是从第一行开始，请将代码中的For curRow = 2 To lastRow修改为For curRow = 1 To lastRow。

希望这段代码能够帮助您实现数据拆分的功能。如果您有任何其他问题，请随时提出。