Excel VBA Sub SplitDataAndSaveToNewWorkbooks() 函数：将数据拆分为多个工作簿并保存

{"title":"Sub SplitDataAndSaveToNewWorkbooks()\n Dim lastRow As Long\n Dim curRow As Long\n Dim sheetName As String\n Dim newWorkbook As Workbook\n Dim savePath As String\n'On Error Resume Next '当代码运行错误时忽略，继续向下运行\n\n\n ' 清除上一次运行拆分的子表内容\n Application.DisplayAlerts = False\n For Each subTable In ThisWorkbook.Worksheets\n If subTable.Name <> "data" And subTable.Name <> "How to operate" Then\n subTable.Cells.Clear\n Application.DisplayAlerts = False\n subTable.Delete\n Application.DisplayAlerts = True\n End If\n Next subTable\n Application.DisplayAlerts = True\n\n\n '获取保存路径，这里为源数据表所在路径下的一个子文件夹"SubTables"\n savePath = ThisWorkbook.path & "\SubTables\"\n If Dir(savePath, vbDirectory) = "" Then\n MkDir savePath\n End If\n\n With Worksheets("data") '修改为你的数据所在的Sheet名称\n lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row '修改为你的数据所在的列\n For curRow = 2 To lastRow '从第二行开始循环，第一行是标题\n sheetName = .Cells(curRow, "X").Value '以第X列作为分割列\n sheetName = Replace(sheetName, "/", "-") ' 将斜杠替换为减号\n sheetName = Replace(sheetName, "?", "") ' 将问号替换为空字符\n If Not SheetExists(sheetName) Then ' SheetExists 函数用来判断是否存在同名的Sheet\n Worksheets.Add After:=Worksheets(Worksheets.Count) '添加新的Sheet\n ActiveSheet.Name = sheetName '以分割列的值命名新的Sheet\n End If\n .Rows(1).Copy Destination:=Worksheets(sheetName).Rows(1)\n .Rows(curRow).Copy Destination:=Worksheets(sheetName).Rows(Worksheets(sheetName).Cells(Worksheets(sheetName).Rows.Count, "X").End(xlUp).Row + 1) '拷贝当前行到对应的Sheet\n Worksheets(sheetName).Columns.AutoFit '自适应单元格宽度\n Next\n End With\n \n For Each subTable In ThisWorkbook.Worksheets\n If subTable.Name <> "data" Then\n '判断是否为由"data"表拆分得到的子表\n Dim isSubTable As Boolean\n isSubTable = False\n For curRow = 2 To lastRow\n If subTable.Name = Worksheets("data").Cells(curRow, "X").Value Then\n isSubTable = True\n Exit For\n End If\n Next curRow\n '如果是"data"表拆分得到的子表，则保存到SubTables文件夹\n If isSubTable Then\n '拼接文件完整路径和文件名\n Dim filePath As String\n filePath = savePath & subTable.Name & ".xlsx"\n '如果文件已经存在，则删除旧文件\n If Dir(filePath) <> "" Then\n Kill filePath\n End If\n \n Set newWorkbook = Workbooks.Add\n subTable.UsedRange.Copy newWorkbook.Worksheets(1).UsedRange\n newWorkbook.Worksheets(1).Columns.AutoFit '自适应单元格宽度\n newWorkbook.SaveAs filePath\n newWorkbook.Close SaveChanges:=False\n End If\n End If\n Next subTable\n\n Worksheets("How to operate").Activate\n MsgBox "The data has been split and saved to SubTables." \n \nEnd Sub\n\nFunction SheetExists(shtName As String) As Boolean\n '判断Sheet是否存在\n SheetExists = False\n For Each sht In ThisWorkbook.Sheets\n If sht.Name = shtName Then\n SheetExists = True\n Exit Function\n End If\n Next sht\nEnd Function这段代码在ActiveSheet.Name = sheetName '以分割列的值命名新的Sheet这里中断是为什么？怎么解决？内容：在这段代码中断的原因可能是sheetName的值包含了不允许作为Sheet名称的特殊字符，比如斜杠（/）、问号（?）等。在命名Sheet时，需要避免使用这些特殊字符。\n\n要解决这个问题，可以在赋值给ActiveSheet.Name之前，先对sheetName进行处理，将其中的特殊字符替换为合法的字符。可以使用Replace函数来替换特殊字符，例如：\n\nvba\nsheetName = Replace(sheetName, "\/", "-") ' 将斜杠替换为减号\nsheetName = Replace(sheetName, "\?", "") ' 将问号替换为空字符\n\n\n将上述代码放置在ActiveSheet.Name = sheetName之前，可以将特殊字符替换为合法的字符，避免中断。