本文于2023年7月25日首发于本人同名公众号：Excel活学活用，更多文章案例请搜索关注！
内容提要
文件拆分工具增加功能：导出到一个工作簿中不同工作表
大家好，我是冷水泡茶，前几期我们分享了EXCEL表格拆分神器、文件拆分工具更新，我本以为基本没有什么问题了。但昨天有粉丝朋友提出新的需求导出到一个工作簿中不同工作表：
其实，导出到一个工作簿我也是考虑到过，并且类似的案例在我们前面分享的文章中也有所涉及。
既然答应了，就赶紧做一下吧，变化的内容也不少，并且还碰到一个“怪异”的错误，值得说一说，我们一起来看一下吧：
用户界面增加控件：
总共增加了3个控件：
1、Excel单一文件（OptExcelOneFile）：导出到新增工作簿中的不同工作表，文件名为待拆分文件的名称加上“_split”。
2、Excel原始文件（OptExcelOriginal）：导出到原始待拆分文件中的不同工作表。
3、文件名加时间（CkbAddTime）：原来为了避免文件同名造成文件被覆盖，在导出的文件名后加上到秒的当前时间，基本不可能重复。但是，我又觉得可能有人想不加时间，所以就放了一外CheckBox，由用户自己选择加还是不加。导出到一个Excel单一文件中不同工作表的，工作表名也作相同处理。但是在导出到Excel原始文件的时候，还是添加了时间，不管选择与否，免得把原来的工作表内容给覆盖了，那麻烦就大了，还是谨慎点好。
4、原来的Excel，Word选项名称稍微改一下。
代码
1、CmdOutPut（导出到）：
把给fileName赋值的语句：
fileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
修改为：
fileName = arrSplit(I) & ".docx"
即，把& "_" & Format(Now, "YYYYMMDDhhmmss")这段给去掉，待后面根据用户的选择再作处理。
2、Sub SaveToFile()：
Sub SaveToFile() '如果没有明细数据，导出选项 If UBound(arrTem, 2) = LBound(arrTem, 2) Then If Not Me.CheckBox1 Then Exit Sub End If End If filesCounter = filesCounter + 1 If Me.CkbAddTime = True Or Me.OptExcelOriginal Then fileName = Left(fileName, InStrRev(fileName, ".") - 1) _ & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx" End If If Me.OptWord Then Call SaveToWord Else Call SaveToExcel End IfEnd Sub
代码解析：
（1）line9~12：如果选中“文件名加时间“或者选中”Excel原始文件“，则给文件名添加当前时间。
（2）line13~17：根据选项判断是导出WORD还是EXCEL。
3、Sub SaveToExcel()：
Sub SaveToExcel() Dim rng As Range, col As Range Dim wb As Workbook, ws As Worksheet Dim wbName As String Dim wsName As String Dim newFile As String '原来导出的是word文件，扩展名改一下 fileName = Replace(fileName, ".docx", ".xlsx") If OptExcel Then Workbooks.Add With ActiveWorkbook Set ws = .Sheets(1) Call WriteToWorkSheet(ws) .SaveAs fileName:=saveFolder & "\" & fileName .Close End With ElseIf OptExcelOneFile Then newFile = Left(filePath, InStrRev(filePath, ".") - 1) & "_split.xlsx" wbName = Right(newFile, Len(newFile) - InStrRev(newFile, "\")) wsName = Replace(fileName, ".xlsx", "") On Error Resume Next Set wb = Workbooks(wbName) On Error GoTo 0 If wb Is Nothing Then ' 如果工作簿未打开，则新建并保存 Set wb = Workbooks.Add wb.SaveAs newFile End If '检查工作表是否存在 On Error Resume Next Set ws = wb.Worksheets(wsName) On Error GoTo 0 If Not ws Is Nothing Then ' 工作表已存在，清除内容和格式 ws.Cells.Clear Else ' 工作表不存在，添加新的工作表 Set ws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count)) ws.Name = wsName End If ws.Activate Call WriteToWorkSheet(ws) wb.Save ElseIf OptExcelOriginal Then Set wb = xlBook wb.Activate wsName = Replace(fileName, ".xlsx", "") '检查工作表是否存在 On Error Resume Next Set ws = wb.Worksheets(wsName) On Error GoTo 0 If Not ws Is Nothing Then ' 工作表已存在，清除内容 ws.Cells.Clear Else ' 工作表不存在，添加新的工作表 Set ws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count)) ws.Name = wsName End If ws.Activate Call WriteToWorkSheet(ws) wb.Save End IfEnd Sub
代码解析：
（1）line9~16：如果选中”Excel独立文件“，则新建工作簿，把第一个工作表Sheets(1)设为ws，接着调用WriteToWorkSheet(ws)过程把数据写入ws，然后保存、关闭工作簿。
（2）line17~40：如果选中”Excel单一文件“，则新建工作簿wb，在拆分文件后添加“_split”作为其文件名。把拆分的fileName去掉“.xlsx”作为工作表名wsName，保存工作簿；检查是否存在wsName工作表，如果存在则清空内容与格式，如果不存在则添加工作表wsName，接着调用WriteToWorkSheet(ws)过程把数据写入ws，然后保存工作簿wb。
（3）line41~58：如果选中”Excel原始文件“，则把xlBook赋值给wb。把拆分的fileName去掉“.xlsx”作为工作表名wsName；检查是否存在wsName工作表，如果存在则清空内容与格式，如果不存在则添加工作表wsName，接着调用WriteToWorkSheet(ws)过程把数据写入ws，然后保存工作簿wb。
4、Sub WriteToWorkSheet(ws As Worksheet)：
Sub WriteToWorkSheet(ws As Worksheet) ws.Activate With ws If Me.CkbTitle Then' .Range(Cells(1, 1), Cells(1, UBound(arrTem, 1) + 1)).Merge .Range("A1").Resize(1, UBound(arrTem, 1) + 1).Merge .Range("A1") = Me.TxbTitle .Range("A1").HorizontalAlignment = xlCenter Set rng = .Range("A2").Resize(UBound(arrTem, 2) + 1, UBound(arrTem, 1) + 1) Else Set rng = .Range("A1").Resize(UBound(arrTem, 2) + 1, UBound(arrTem, 1) + 1) End If rng.NumberFormat = "@" rng = Application.WorksheetFunction.Transpose(arrTem) For I = 1 To rng.Columns.Count If Not IsArrEmpty(arrNumColFields) Then For j = LBound(arrNumColFields) To UBound(arrNumColFields) If rng.Cells(1, I).Value = arrNumColFields(j) Then Set col = rng.Columns(I) col.NumberFormatLocal = "_ * #,##0.00_ ;_ * -#,##0.00_ ;_ * ""-""??_ ;_ @_ " col.Value = col.Value End If Next End If If Not IsArrEmpty(arrDateColFields) Then For j = LBound(arrDateColFields) To UBound(arrDateColFields) If rng.Cells(1, I).Value = arrDateColFields(j) Then Set col = rng.Columns(I) col.NumberFormatLocal = "yyyy/m/d" col.Value = col.Value End If Next End If Next rng.Columns.AutoFit End WithEnd Sub
代码解析：每个导出EXCEL的选项都有写入工作表的代码，把它独立出来做成一个过程供调用，减少重复代码量。
（1）line5~6：第5行是注释掉的代码，原来是把标题合并居中的，在前面的版本中运行正常，在本次修改的版本中，导出到新建的工作簿运行也正常，但在导出到原始待拆分文件时，就报错：
这不是同样的操作吗？为什么会这样呢？试了好多方法，网上也搜了，没有结果，百思不得其解。也问了AI，也没有得到解决，后来它提到了“Resize”，让我想到了用“Resize”的方法来得到一个区域，这回成功了。这就是我在开头提到的“怪异”的错误。
（2）其他代码没有变化，第14行把数组写入单元格，接下来如果有日期、数值列的，进行格式设置。
5、Sub OptExcel_Change()：
Private Sub OptExcel_Change() Dim opt As Control For Each opt In Controls If TypeOf opt Is MSForms.OptionButton Then If opt = True Then opt.ForeColor = vbRed Else opt.ForeColor = vbBlue End If End If NextEnd Sub
代码解析：设置选项控件的文字颜色，选中的为红色，未选中的为蓝色。原来只有两个选项控件，可以直接指定颜色，现在选项控件增加了，通过一个循环来判断OptionButton的值来设置。
喜欢就点个赞、点在看、留个言呗！