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
    For Each subTable In ThisWorkbook.Worksheets
    If subTable.Name <> 'data' And subTable.Name <> 'How to operate' Then
        subTable.Cells.Clear
        Application.DisplayAlerts = False
        subTable.Delete
        Application.DisplayAlerts = True
    End If
    Next subTable
    Application.DisplayAlerts = True


    '获取保存路径，这里为源数据表所在路径下的一个子文件夹'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

    Worksheets('How to operate').Activate
    MsgBox 'The data has been split and saved to 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

代码说明:

清除上一次运行拆分的子表内容: 循环遍历工作簿中的所有工作表，如果工作表名称不为'data'或'How to operate'，则清空工作表内容并删除工作表。
获取保存路径: 获取源数据表所在的路径，并在该路径下创建一个名为'SubTables'的文件夹，用于保存拆分后的工作簿。
循环拆分数据: 循环遍历源数据表'data'中的每行数据，将第X列的值作为新工作表的名称。
创建新工作表: 如果新工作表的名称不存在，则创建一个新的工作表并以第X列的值命名。
复制数据到新工作表: 将源数据表的第一行复制到新工作表的首行，将当前行数据复制到新工作表的最后一行。
自适应单元格宽度: 自动调整新工作表中所有列的宽度，以适应数据内容。
保存工作簿: 将所有拆分后的工作簿保存到'SubTables'文件夹下，文件名与工作表名称相同。
错误处理: 使用'SheetExists'函数判断工作表名称是否已存在，防止重复创建工作表。

代码运行中断问题分析及解决方法:

错误提示'此名称已被使用'可能出现的原因：

源数据表中的分割列（第X列）的值不唯一，导致创建重复的工作表名称。

解决方法：

确保分割列的值是唯一的。
如果无法保证分割列的值唯一，可以在创建工作表名称时添加一个唯一的标识符，例如序号或时间戳。

修改后的代码：

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

    ' 清除上一次运行拆分的子表内容
    Application.DisplayAlerts = False
    For Each subTable In ThisWorkbook.Worksheets
        If subTable.Name <> 'data' And subTable.Name <> 'How to operate' Then
            subTable.Cells.Clear
            Application.DisplayAlerts = False
            subTable.Delete
            Application.DisplayAlerts = True
        End If
    Next subTable
    Application.DisplayAlerts = True

    '获取保存路径
    savePath = ThisWorkbook.path & '\SubTables\'
    If Dir(savePath, vbDirectory) = '' Then
        MkDir savePath
    End If

    With Worksheets('data')
        lastRow = .Cells(.Rows.Count, 'A').End(xlUp).Row
        For curRow = 2 To lastRow
            sheetName = .Cells(curRow, 'X').Value
            i = 1
            Do While SheetExists(sheetName)
                sheetName = .Cells(curRow, 'X').Value & '_' & i
                i = i + 1
            Loop
            Worksheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = sheetName
            .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)
            Worksheets(sheetName).Columns.AutoFit
        Next
    End With

    ' 保存数据到新工作簿
    For Each subTable In ThisWorkbook.Worksheets
        If subTable.Name <> 'data' Then
            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
            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

    Worksheets('How to operate').Activate
    MsgBox 'The data has been split and saved to SubTables.'
End Sub

Function SheetExists(shtName As String) As Boolean
    SheetExists = False
    For Each sht In ThisWorkbook.Sheets
        If sht.Name = shtName Then
            SheetExists = True
            Exit Function
        End If
    Next sht
End Function

修改说明：

在创建新的工作表名称之前，添加了一个循环判断，如果名称已存在，则在名称后面添加一个序号，直到名称不重复为止。
确保每次循环中都创建新的工作表名称，即使遇到重复的分割列值。