VBA学习(77)：Excel表格拆分通用版终极神器
1.用户窗体-定义变量：
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim wrdApp As Object
Dim wrdDoc As Object
Dim wrdTable As Object
Dim filePath As String
Dim fileName As String
Dim saveFolder As String
Dim sht As Worksheet
Dim shtName As String
Dim lastRow As Integer, lastCol As Integer
Dim rng As Range
Dim arr(), arrDate(), arrSplit(), tbTitle(), arrNumber(), arrFilter()
Dim SplitCol As Integer
Dim dateCol As Integer, NumberCol As Integer
Dim filterCol As Integer
Dim arrTem()
Dim newRow As Integer
Dim filesCounter As Integer用户窗体-Sub CkbTitle
Private Sub CkbTitle_Click()If Me.CkbTitle ThenMe.TxbTitle.Visible = TrueElseMe.TxbTitle.Visible = FalseMe.TxbTitle = ""End If
End Sub代码解析：插入标题，点击勾选则显示文本框，再点击取消勾选，隐藏文本框。
用户窗体-Sub CmbFilterColumn
Private Sub CmbFilterColumn_Change()On Error Resume NextDim dicFilter As ObjectSet dicFilter = CreateObject("Scripting.Dictionary")For i = 1 To lastColIf arr(1, i) = Me.CmbFilterColumn ThenfilterCol = iExit ForEnd IfNextFor i = 1 To lastColIf arr(1, i) = Me.CmbSplitColumn ThenSplitCol = iExit ForEnd IfNextFor i = 2 To lastRowIf Me.CmbSplit = "" ThendicFilter(arr(i, filterCol)) = 1ElseIf arr(i, SplitCol) = Me.CmbSplit ThendicFilter(arr(i, filterCol)) = 1End IfEnd IfNextarrFilter = dicFilter.keysCall SortArray(arrFilter)Me.CmbInclude.List = arrFilterMe.CmbExclude.List = arrFilterMe.CmbInclude = ""Me.CmbInclude = ""End Sub代码解析：其他筛选，改变筛选字段，重新设置其下两个复合框的List
用户窗体-Sub CmbSplit_Change
Private Sub CmbSplit_Change()On Error Resume NextDim dicDate As ObjectDim dicNumber As ObjectDim dicFilter As ObjectDim strArr As String, strCmb As StringSet dicDate = CreateObject("Scripting.Dictionary")Set dicNumber = CreateObject("Scripting.Dictionary")Set dicFilter = CreateObject("Scripting.Dictionary")For i = 2 To lastRowstrArr = CStr(arr(i, SplitCol))strCmb = CStr(Me.CmbSplit)If dateCol > 0 ThenIf strArr = strCmb ThendicDate(arr(i, dateCol)) = 1End IfEnd IfIf NumberCol > 0 ThenIf strArr = strCmb ThendicNumber(arr(i, NumberCol)) = 1End IfEnd IfIf filterCol > 0 ThenIf strArr = strCmb ThendicFilter(arr(i, filterCol)) = 1End IfEnd IfNextMe.CmbMinDate.ClearMe.CmbMaxDate.CleararrDate = dicDate.keysCall SortArray(arrDate)Me.CmbMinDate.List = arrDateMe.CmbMaxDate.List = arrDateMe.CmbMinNumber.ClearMe.CmbMaxNumber.CleararrNumber = dicNumber.keysCall SortArray(arrNumber)Me.CmbMinNumber.List = arrNumberMe.CmbMaxNumber.List = arrNumberMe.CmbInclude.ClearMe.CmbExclude.CleararrFilter = dicFilter.keysCall SortArray(arrFilter)Me.CmbInclude.List = arrFilterMe.CmbExclude.List = arrFilterEnd Sub代码解析：单选项目change事件，右边的三个筛选都要随之改变。
用户窗体-Sub CmbSplitColumn_Change
Private Sub CmbSplitColumn_Change()'On Error Resume NextDim dicSplit As ObjectDim dicNumber As ObjectDim dicDate As ObjectDim dicFilter As ObjectSet dicSplit = CreateObject("Scripting.Dictionary")Set dicDate = CreateObject("Scripting.Dictionary")Set dicNumber = CreateObject("Scripting.Dictionary")Set dicFilter = CreateObject("Scripting.Dictionary")For i = 1 To lastColIf arr(1, i) = Me.CmbDateColumn ThendateCol = iElseIf arr(1, i) = Me.CmbSplitColumn ThenSplitCol = iElseIf arr(1, i) = Me.CmbNumberColumn ThenNumberCol = iElseIf arr(1, i) = Me.CmbFilterColumn ThenfilterCol = iEnd IfNextFor i = 2 To lastRowIf SplitCol > 0 ThendicSplit(arr(i, SplitCol)) = 1End IfIf dateCol > 0 ThendicDate(arr(i, dateCol)) = 1End IfIf NumberCol > 0 ThendicNumber(arr(i, NumberCol)) = 1End IfIf filterCol > 0 ThendicFilter(arr(i, filterCol)) = 1End IfNextarrSplit = dicSplit.keysMe.CmbSplit.List = dicSplit.keysarrDate = dicDate.keysCall SortArray(arrDate)arrNumber = dicNumber.keysCall SortArray(arrNumber)arrFilter = dicFilter.keysCall SortArray(arrFilter)Me.CmbMinDate.List = arrDateMe.CmbMaxDate.List = arrDateMe.CmbMinNumber.List = arrNumberMe.CmbMaxNumber.List = arrNumberMe.CmbInclude.List = arrFilterMe.CmbExclude.List = arrFilterMe.CmbMinDate = ""Me.CmbMaxDate = ""Me.CmbMinNumber = ""Me.CmbMaxNumber = ""Me.CmbSplit = ""End Sub代码解析：拆分列的change事件，右边的三个筛选都随之改变。
用户窗体-Sub CmbDateColumn_Change
Private Sub CmbDateColumn_Change()On Error Resume NextDim dicDate As ObjectDim arrMinDate(), arrMaxDate()Set dicDate = CreateObject("Scripting.Dictionary")For i = 1 To lastColIf arr(1, i) = Me.CmbDateColumn ThendateCol = iExit ForEnd IfNextFor i = 1 To lastColIf arr(1, i) = Me.CmbSplitColumn ThenSplitCol = iExit ForEnd IfNextFor i = 2 To lastRowIf Me.CmbSplit = "" ThendicDate(arr(i, dateCol)) = 1ElseIf arr(i, SplitCol) = Me.CmbSplit ThendicDate(arr(i, dateCol)) = 1End IfEnd IfNextarrDate = dicDate.keysCall SortArray(arrDate)Me.CmbMinDate.List = arrDateMe.CmbMaxDate.List = arrDateMe.CmbMinDate = ""Me.CmbMaxDate = ""End Sub代码解析：日期筛选列的change事件，其下两个筛选都随之改变。
用户窗体-Sub CmbNumberColumn_Change
Private Sub CmbNumberColumn_Change()On Error Resume NextDim dicNumber As ObjectDim arrMinNumber(), arrMaxnumber()Set dicNumber = CreateObject("Scripting.Dictionary")For i = 1 To lastColIf arr(1, i) = Me.CmbNumberColumn ThenNumberCol = iExit ForEnd IfNextFor i = 1 To lastColIf arr(1, i) = Me.CmbSplitColumn ThenSplitCol = iExit ForEnd IfNextFor i = 2 To lastRowIf Me.CmbSplit = "" ThendicNumber(arr(i, NumberCol)) = 1ElseIf arr(i, SplitCol) = Me.CmbSplit ThendicNumber(arr(i, NumberCol)) = 1End IfEnd IfNextarrNumber = dicNumber.keysCall SortArray(arrNumber)Me.CmbMinNumber.List = arrNumberMe.CmbMaxNumber.List = arrNumberMe.CmbMinNumber = ""Me.CmbMaxNumber = ""End Sub代码解析：数值筛选列的change事件。
用户窗体-Sub CmbSheets_Change
Private Sub CmbSheets_Change()Dim ckBox As ControlDim ctrl As ControlshtName = Me.CmbSheetsSet xlSheet = xlBook.Sheets(shtName)Set rng = xlSheet.UsedRangearr = rng.ValuelastRow = UBound(arr, 1)lastCol = UBound(arr, 2)For i = 1 To lastColReDim Preserve tbTitle(1 To i)tbTitle(i) = arr(1, i)NextFor Each ctrl In Me.ControlsIf InStr(ctrl.Name, "CheckBox_") > 0 ThenMe.Controls.Remove ctrl.NameEnd IfNextleftPos = Me.LbColumn.Left + 10 ' 左侧位置topPos = Me.LbColumn.Top + Me.LbColumn.Height + 2 ' 复选框的顶部位置iwidth = 70'For i = 1 To lastColSet ckBox = Me.Controls.Add("Forms.CheckBox.1", "CheckBox_" & i)With ckBox.Left = leftPos.Top = topPos.Width = iwidth.Height = 20.Caption = tbTitle(i).Value = TrueEnd With'更新位置If (i) Mod 4 = 0 Then'换行leftPos = Me.LbColumn.Left + 10topPos = topPos + 20Else'同行下一个位置leftPos = leftPos + iwidthEnd IfNextMe.CmbSplitColumn.ClearMe.CmbDateColumn.ClearMe.CmbNumberColumn.ClearMe.CmbFilterColumn.ClearFor i = 1 To lastColIf IsDate(arr(2, i)) Then '日期字段Me.CmbDateColumn.AddItem arr(1, i)ElseIf IsNumeric(arr(2, i)) Then '数值字段Me.CmbNumberColumn.AddItem arr(1, i)Else '除日期、数值字段，其他可供筛选字段Me.CmbFilterColumn.AddItem (arr(1, i))End IfNextMe.CmdSelect.Visible = TrueMe.CmbDateColumn = ""Me.CmbMinDate.ClearMe.CmbMaxDate.ClearMe.CmbNumberColumn = ""Me.CmbMinNumber.ClearMe.CmbMaxNumber.ClearMe.CmbFilterColumn = ""Me.CmbInclude.ClearMe.CmbExclude.ClearMe.CmbSplit.CleardateCol = 0SplitCol = 0With Me.CmbSplitColumn.Clear.List = tbTitle.Text = .List(0)End WithEnd Sub代码解析：拆分目标工作表的change事件，窗体上的大部筛选都要重设。
用户窗体-Sub CmdChooseFile_Click
Private Sub CmdChooseFile_Click()Set xlApp = CreateObject("Excel.Application")Me.TxbExcelFile = FileSelectedfilePath = Me.TxbExcelFileIf Not filePath = "" ThenSet xlBook = xlApp.Workbooks.Open(filePath)ElseMsgBox "请选择文件！"Exit SubEnd IfFor Each sht In xlBook.WorksheetsIf sht.Cells(1, 1) <> "" ThenMe.CmbSheets.AddItem sht.NameEnd IfNextMe.CmbSheets.Text = Me.CmbSheets.List(0)shtName = Me.CmbSheetsEnd Sub代码解析：选择拆分文件。
用户窗体-Sub CmdChoosePath_Click
Private Sub CmdChoosePath_Click()Dim preFolder As StringpreFolder = Me.TxbWordPathIf Not IsFolderExists(preFolder) ThenpreFolder = ThisWorkbook.PathEnd IfsaveFolder = PathSelectedIf Not saveFolder = "" ThenMe.TxbWordPath = saveFolderElsesaveFolder = preFolderMe.TxbWordPath = saveFolderEnd If
End Sub代码解析：选择保存路径。
用户窗体-Sub CmbDateColumn_Change
Private Sub CmdOutPut_Click()On Error Resume NextDim arrTitle()Dim minDate As Date, maxDate As DateDim minNumber As Double, maxNumber As DoubleDim strInclude As String, strExclude As StringApplication.ScreenUpdating = FalsefilesCounter = 0t = 0For i = LBound(tbTitle) To UBound(tbTitle)If Me.Controls("CheckBox_" & i) = True Thent = 1Exit ForEnd IfNextIf t = 0 ThenMsgBox "至少选择一列"Exit SubEnd IfIf Me.OptWord ThenSet wrdApp = CreateObject("Word.Application")End If
' wrdApp.Visible = True ' 将Word应用程序设置为可见For i = 1 To lastColIf Controls("CheckBox_" & i) ThenReDim Preserve arrTitle(k)arrTitle(k) = Controls("CheckBox_" & i).Captionk = k + 1End IfNextnewRow = UBound(arrTitle, 1)ReDim arrTem(0 To newRow, 0 To 0)For i = 0 To newRowarrTem(i, 0) = arrTitle(i)Next'日期范围If Me.CmbDateColumn <> "" ThenIf Me.CmbMinDate = "" ThenminDate = arrDate(LBound(arrDate))ElseminDate = CDate(Me.CmbMinDate)End IfIf Me.CmbMaxDate = "" ThenmaxDate = arrDate(UBound(arrDate))ElsemaxDate = CDate(Me.CmbMaxDate)End IfEnd If'金额范围If Me.CmbNumberColumn <> "" ThenIf Me.CmbMinNumber = "" ThenminNumber = CDbl(arrNumber(LBound(arrNumber)))ElseminNumber = CDbl(Me.CmbMinNumber)End IfIf Me.CmbMaxNumber = "" ThenmaxNumber = CDbl(arrNumber(UBound(arrNumber)))ElsemaxNumber = CDbl(Me.CmbMaxNumber)End IfEnd If'筛选字段If Me.CmbFilterColumn <> "" ThenIf Me.CmbInclude = "" ThenstrInclude = ""ElsestrInclude = CStr(Me.CmbInclude)End IfIf Me.CmbExclude = "" ThenstrExclude = "1234567890qwertyuiop"ElsestrExclude = CStr(Me.CmbExclude)End IfEnd IfIf Me.CmbSplitColumn = "" Then '客户为空MsgBox "拆分字段不能为空"Exit SubEnd IfIf Me.CmbSplit = "" Then '未选具体拆分项目 第一层IFIf Me.CmbDateColumn = "" Then '未选日期列 第二层IFIf Me.CmbNumberColumn = "" Then '未选数值列 第三层IFIf Me.CmbFilterColumn = "" Then '未选筛选列 第四层IFFor i = LBound(arrSplit) To UBound(arrSplit)For j = 2 To lastRowIf arr(j, SplitCol) = arrSplit(i) Thenm = UBound(arrTem, 2) + 1ReDim Preserve arrTem(0 To newRow, 0 To m)For k = 0 To newRowFor n = 1 To lastColIf arr(1, n) = arrTem(k, 0) ThenarrTem(k, m) = arr(j, n)End IfNextNextEnd IfNextfileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"fileName = Replace(fileName, "\", "_")fileName = Replace(fileName, "/", "_")Call SaveToFileReDim Preserve arrTem(0 To newRow, 0 To 0)
' StopNextElse '选了筛选列 e1 第四层IF elseFor i = LBound(arrSplit) To UBound(arrSplit)For j = 2 To lastRowIf arr(j, SplitCol) = arrSplit(i) And InStr(arr(j, filterCol), strInclude) > 0 _And InStr(arr(j, filterCol), strExclude) = 0 Thenm = UBound(arrTem, 2) + 1ReDim Preserve arrTem(0 To newRow, 0 To m)For k = 0 To newRowFor n = 1 To lastColIf arr(1, n) = arrTem(k, 0) ThenarrTem(k, m) = arr(j, n)End IfNextNextEnd IfNextfileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"fileName = Replace(fileName, "\", "_")fileName = Replace(fileName, "/", "_")Call SaveToFileReDim Preserve arrTem(0 To newRow, 0 To 0)NextEnd If '第四层IF endElse '选了数值列 第三层IF elseIf Me.CmbFilterColumn = "" Then '未选筛选列For i = LBound(arrSplit) To UBound(arrSplit)For j = 2 To lastRowIf arr(j, SplitCol) = arrSplit(i) And CDbl(arr(j, NumberCol)) >= minNumber _And CDbl(arr(j, NumberCol)) <= maxNumber Thenm = UBound(arrTem, 2) + 1ReDim Preserve arrTem(0 To newRow, 0 To m)For k = 0 To newRowFor n = 1 To lastColIf arr(1, n) = arrTem(k, 0) ThenarrTem(k, m) = arr(j, n)End IfNextNextEnd IfNextfileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"fileName = Replace(fileName, "\", "_")fileName = Replace(fileName, "/", "_")Call SaveToFileReDim Preserve arrTem(0 To newRow, 0 To 0)NextElse '选了筛选列 E3For i = LBound(arrSplit) To UBound(arrSplit)For j = 2 To lastRowIf arr(j, SplitCol) = arrSplit(i) And CDbl(arr(j, NumberCol)) >= minNumber _And CDbl(arr(j, NumberCol)) <= maxNumber _And InStr(arr(j, filterCol), strInclude) > 0 _And InStr(arr(j, filterCol), strExclude) = 0 Thenm = UBound(arrTem, 2) + 1ReDim Preserve arrTem(0 To newRow, 0 To m)For k = 0 To newRowFor n = 1 To lastColIf arr(1, n) = arrTem(k, 0) ThenarrTem(k, m) = arr(j, n)End IfNextNextEnd IfNextfileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"fileName = Replace(fileName, "\", "_")fileName = Replace(fileName, "/", "_")Call SaveToFileReDim Preserve arrTem(0 To newRow, 0 To 0)NextEnd IfEnd If '第三层IF endElse '第二层IF else 选择了日期列If Me.CmbNumberColumn = "" Then '选择了日期列，未选数值列If Me.CmbFilterColumn = "" Then '选择了日期列，未选数值列,未选筛选列For i = LBound(arrSplit) To UBound(arrSplit)For j = 2 To lastRowIf arr(j, SplitCol) = arrSplit(i) And CDate(arr(j, dateCol)) >= minDate _And CDate(arr(j, dateCol)) <= maxDate Thenm = UBound(arrTem, 2) + 1ReDim Preserve arrTem(0 To newRow, 0 To m)For k = 0 To newRowFor n = 1 To lastColIf arr(1, n) = arrTem(k, 0) ThenarrTem(k, m) = arr(j, n)End IfNextNextEnd IfNextfileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"fileName = Replace(fileName, "\", "_")fileName = Replace(fileName, "/", "_")Call SaveToFileReDim Preserve arrTem(0 To newRow, 0 To 0)NextElse ' '选择了日期列，未选数值列,选了筛选列For i = LBound(arrSplit) To UBound(arrSplit)For j = 2 To lastRowIf arr(j, SplitCol) = arrSplit(i) And CDate(arr(j, dateCol)) >= minDate _And CDate(arr(j, dateCol)) <= maxDate _And InStr(arr(j, filterCol), strInclude) > 0 _And InStr(arr(j, filterCol), strExclude) = 0 Thenm = UBound(arrTem, 2) + 1ReDim Preserve arrTem(0 To newRow, 0 To m)For k = 0 To newRowFor n = 1 To lastColIf arr(1, n) = arrTem(k, 0) ThenarrTem(k, m) = arr(j, n)End IfNextNextEnd IfNextfileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"fileName = Replace(fileName, "\", "_")fileName = Replace(fileName, "/", "_")Call SaveToFileReDim Preserve arrTem(0 To newRow, 0 To 0)NextEnd IfElse '选择了日期列，选了数值列If Me.CmbFilterColumn = "" Then '选择了日期列，选了数值列,未选筛选列For i = LBound(arrSplit) To UBound(arrSplit)For j = 2 To lastRowIf arr(j, SplitCol) = arrSplit(i) And CDate(arr(j, dateCol)) >= minDate _And CDate(arr(j, dateCol)) <= maxDate _And CDbl(arr(j, NumberCol)) >= minNumber _And CDbl(arr(j, NumberCol)) <= maxNumber Thenm = UBound(arrTem, 2) + 1ReDim Preserve arrTem(0 To newRow, 0 To m)For k = 0 To newRowFor n = 1 To lastColIf arr(1, n) = arrTem(k, 0) ThenarrTem(k, m) = arr(j, n)End IfNextNextEnd IfNextfileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"fileName = Replace(fileName, "\", "_")fileName = Replace(fileName, "/", "_")Call SaveToFileReDim Preserve arrTem(0 To newRow, 0 To 0)NextElse '选择了日期列，选了数值列,选了筛选列For i = LBound(arrSplit) To UBound(arrSplit)For j = 2 To lastRowIf arr(j, SplitCol) = arrSplit(i) And CDate(arr(j, dateCol)) >= minDate _And CDate(arr(j, dateCol)) <= maxDate _And CDbl(arr(j, NumberCol)) >= minNumber _And CDbl(arr(j, NumberCol)) <= maxNumber _And InStr(arr(j, filterCol), strInclude) > 0 _And InStr(arr(j, filterCol), strExclude) = 0 Thenm = UBound(arrTem, 2) + 1ReDim Preserve arrTem(0 To newRow, 0 To m)For k = 0 To newRowFor n = 1 To lastColIf arr(1, n) = arrTem(k, 0) ThenarrTem(k, m) = arr(j, n)End IfNextNextEnd IfNextfileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"fileName = Replace(fileName, "\", "_")fileName = Replace(fileName, "/", "_")Call SaveToFileReDim Preserve arrTem(0 To newRow, 0 To 0)NextEnd IfEnd IfEnd IfElse '选择了具体拆分项目If Me.CmbDateColumn = "" Then '未选日期列 第二层IFIf Me.CmbNumberColumn = "" Then '未选数值列 第三层IFIf Me.CmbFilterColumn = "" Then '未选筛选列 第四层IFFor j = 2 To lastRowIf arr(j, SplitCol) = Me.CmbSplit Thenm = UBound(arrTem, 2) + 1ReDim Preserve arrTem(0 To newRow, 0 To m)For k = 0 To newRowFor n = 1 To lastColIf arr(1, n) = arrTem(k, 0) ThenarrTem(k, m) = arr(j, n)End IfNextNextEnd IfNextfileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"fileName = Replace(fileName, "\", "_")fileName = Replace(fileName, "/", "_")Call SaveToFileReDim Preserve arrTem(0 To newRow, 0 To 0)Else '选了筛选列 e1 第四层IF elseFor j = 2 To lastRowIf arr(j, SplitCol) = Me.CmbSplit And InStr(arr(j, filterCol), strInclude) > 0 _And InStr(arr(j, filterCol), strExclude) = 0 Thenm = UBound(arrTem, 2) + 1ReDim Preserve arrTem(0 To newRow, 0 To m)For k = 0 To newRowFor n = 1 To lastColIf arr(1, n) = arrTem(k, 0) ThenarrTem(k, m) = arr(j, n)End IfNextNextEnd IfNextfileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"fileName = Replace(fileName, "\", "_")fileName = Replace(fileName, "/", "_")Call SaveToFileReDim Preserve arrTem(0 To newRow, 0 To 0)End If '第四层IF endElse '选了数值列 第三层IF elseIf Me.CmbFilterColumn = "" Then '未选筛选列For j = 2 To lastRowIf arr(j, SplitCol) = Me.CmbSplit And CDbl(arr(j, NumberCol)) >= minNumber _And CDbl(arr(j, NumberCol)) <= maxNumber Thenm = UBound(arrTem, 2) + 1ReDim Preserve arrTem(0 To newRow, 0 To m)For k = 0 To newRowFor n = 1 To lastColIf arr(1, n) = arrTem(k, 0) ThenarrTem(k, m) = arr(j, n)End IfNextNextEnd IfNextfileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"fileName = Replace(fileName, "\", "_")fileName = Replace(fileName, "/", "_")Call SaveToFileReDim Preserve arrTem(0 To newRow, 0 To 0)Else '选了筛选列 E3For j = 2 To lastRowIf arr(j, SplitCol) = Me.CmbSplit And CDbl(arr(j, NumberCol)) >= minNumber _And CDbl(arr(j, NumberCol)) <= maxNumber _And InStr(arr(j, filterCol), strInclude) > 0 _And InStr(arr(j, filterCol), strExclude) = 0 Thenm = UBound(arrTem, 2) + 1ReDim Preserve arrTem(0 To newRow, 0 To m)For k = 0 To newRowFor n = 1 To lastColIf arr(1, n) = arrTem(k, 0) ThenarrTem(k, m) = arr(j, n)End IfNextNextEnd IfNextfileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"fileName = Replace(fileName, "\", "_")fileName = Replace(fileName, "/", "_")Call SaveToFileReDim Preserve arrTem(0 To newRow, 0 To 0)End IfEnd If '第三层IF endElse '第二层IF else 选择了日期列If Me.CmbNumberColumn = "" Then '选择了日期列，未选数值列If Me.CmbFilterColumn = "" Then '选择了日期列，未选数值列,未选筛选列For j = 2 To lastRowIf arr(j, SplitCol) = Me.CmbSplit And CDate(arr(j, dateCol)) >= minDate _And CDate(arr(j, dateCol)) <= maxDate Thenm = UBound(arrTem, 2) + 1ReDim Preserve arrTem(0 To newRow, 0 To m)For k = 0 To newRowFor n = 1 To lastColIf arr(1, n) = arrTem(k, 0) ThenarrTem(k, m) = arr(j, n)End IfNextNextEnd IfNextfileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"fileName = Replace(fileName, "\", "_")fileName = Replace(fileName, "/", "_")Call SaveToFileReDim Preserve arrTem(0 To newRow, 0 To 0)Else ' '选择了日期列，未选数值列,选了筛选列For j = 2 To lastRowIf arr(j, SplitCol) = Me.CmbSplit And CDate(arr(j, dateCol)) >= minDate _And CDate(arr(j, dateCol)) <= maxDate _And InStr(arr(j, filterCol), strInclude) > 0 _And InStr(arr(j, filterCol), strExclude) = 0 Thenm = UBound(arrTem, 2) + 1ReDim Preserve arrTem(0 To newRow, 0 To m)For k = 0 To newRowFor n = 1 To lastColIf arr(1, n) = arrTem(k, 0) ThenarrTem(k, m) = arr(j, n)End IfNextNextEnd IfNextfileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"fileName = Replace(fileName, "\", "_")fileName = Replace(fileName, "/", "_")Call SaveToFileReDim Preserve arrTem(0 To newRow, 0 To 0)End IfElse '选择了日期列，选了数值列If Me.CmbFilterColumn = "" Then '选择了日期列，选了数值列,未选筛选列For j = 2 To lastRowIf arr(j, SplitCol) = Me.CmbSplit And CDate(arr(j, dateCol)) >= minDate _And CDate(arr(j, dateCol)) <= maxDate _And CDbl(arr(j, NumberCol)) >= minNumber _And CDbl(arr(j, NumberCol)) <= maxNumber Thenm = UBound(arrTem, 2) + 1ReDim Preserve arrTem(0 To newRow, 0 To m)For k = 0 To newRowFor n = 1 To lastColIf arr(1, n) = arrTem(k, 0) ThenarrTem(k, m) = arr(j, n)End IfNextNextEnd IfNextfileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"fileName = Replace(fileName, "\", "_")fileName = Replace(fileName, "/", "_")Call SaveToFileReDim Preserve arrTem(0 To newRow, 0 To 0)Else '选择了日期列，选了数值列,选了筛选列For j = 2 To lastRowIf arr(j, SplitCol) = Me.CmbSplit And CDate(arr(j, dateCol)) >= minDate _And CDate(arr(j, dateCol)) <= maxDate _And CDbl(arr(j, NumberCol)) >= minNumber _And CDbl(arr(j, NumberCol)) <= maxNumber _And InStr(arr(j, filterCol), strInclude) > 0 _And InStr(arr(j, filterCol), strExclude) = 0 Thenm = UBound(arrTem, 2) + 1ReDim Preserve arrTem(0 To newRow, 0 To m)For k = 0 To newRowFor n = 1 To lastColIf arr(1, n) = arrTem(k, 0) ThenarrTem(k, m) = arr(j, n)End IfNextNextEnd IfNextfileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"fileName = Replace(fileName, "\", "_")fileName = Replace(fileName, "/", "_")Call SaveToFileReDim Preserve arrTem(0 To newRow, 0 To 0)End IfEnd IfEnd IfEnd IfMsgBox "成功拆分【" & filesCounter & "】个文件"'打开拆分文件所在目录Shell "explorer.exe " & saveFolder, vbMaximizedFocusOn Error Resume NextIf Not xlBook Is Nothing Then'工作簿已打开，执行关闭xlBook.Close FalseEnd IfwrdApp.QuitxlApp.QuitSet wrdTable = NothingSet wrdDoc = NothingSet wrdApp = NothingSet xlSheet = NothingSet xlBook = NothingSet xlApp = NothingUnload MeApplication.ScreenUpdating = True
End Sub代码解析：导出文件
1、如果没有选择“单选项目”，则会将拆分列的所有项目拆分为单独文件。
2、循环拆分项目，根据右边筛选条件，提取数据，存到数据，导出到文件。
3、代码量主要在选择判断方面。
用户窗体-其他代码
Private Sub CmdSelect_Click()If Me.CmdSelect.Caption = "全选" ThenFor i = LBound(tbTitle) To UBound(tbTitle)Me.Controls("CheckBox_" & i) = TrueNextMe.CmdSelect.Caption = "全消"Me.CmdSelect.BackColor = &HC0FFC0ElseFor i = LBound(tbTitle) To UBound(tbTitle)Me.Controls("CheckBox_" & i) = FalseNextMe.CmdSelect.Caption = "全选"Me.CmdSelect.BackColor = &H8080FFEnd If
End SubPrivate Sub OptExcel_Change()If OptExcel ThenMe.OptExcel.ForeColor = vbRedMe.OptWord.ForeColor = vbBlueElseMe.OptExcel.ForeColor = vbBlueMe.OptWord.ForeColor = vbRedEnd If
End SubPrivate Sub UserForm_Initialize()saveFolder = ThisWorkbook.PathMe.TxbWordPath = saveFolder
End SubPrivate Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)On Error Resume NextIf Not xlBook Is Nothing Then'工作簿已打开，执行关闭xlBook.Close FalseEnd IfwrdApp.QuitxlApp.QuitSet wrdTable = NothingSet wrdDoc = NothingSet wrdApp = NothingSet xlSheet = NothingSet xlBook = NothingSet xlApp = NothingEnd SubSub SaveToFile()'如果没有明细数据，导出选项If UBound(arrTem, 2) = LBound(arrTem, 2) ThenIf Not Me.CheckBox1 ThenExit SubEnd IfEnd IffilesCounter = filesCounter + 1If Me.OptExcel ThenCall SaveToExcelElseCall SaveToWordEnd If
End Sub
Sub SaveToWord()'Stop'创建新的Word文档Set wrdDoc = wrdApp.Documents.AddSet myrange = wrdDoc.Range(0, 0)With myrange.InsertBefore Me.TxbTitle & vbCrLfWith .Font.Name = "黑体".Size = 16'.Bold = TrueEnd With'.ParagraphFormat.Alignment = wdAlignParagraphCenter'.InsertParagraphAfter.Collapse Direction:=wdCollapseEndEnd WithWith wrdDoc.Paragraphs(1).Alignment = wdAlignParagraphCenterEnd With'添加新的表格Set wrdTable = wrdDoc.Tables.Add(myrange, UBound(arrTem, 2) + 1, newRow + 1)'设置表格边框格式为灰色虚线With wrdTable.Style = "网格型"End WithFor c = 1 To UBound(arrTem, 2) + 1For d = 1 To newRow + 1wrdTable.Cell(c, d).Range.Text = arrTem(d - 1, c - 1)NextNextwrdDoc.SaveAs saveFolder & "\" & fileNamewrdDoc.Close SaveChanges:=False
End SubSub SaveToExcel()'原来导出的是word文件，扩展名改一下fileName = Replace(fileName, ".docx", ".xlsx")Workbooks.AddWith ActiveWorkbookIf Me.CkbTitle Then.Sheets(1).Range(Cells(1, 1), Cells(1, UBound(arrTem, 1) + 1)).MergeCells = True.Sheets(1).Range("A1") = Me.TxbTitle.Sheets(1).Range("A1").HorizontalAlignment = xlCenter.Sheets(1).Range("A2").Resize(UBound(arrTem, 2) + 1, UBound(arrTem, 1) + 1) = Application.WorksheetFunction.Transpose(arrTem)Else.Sheets(1).Range("A1").Resize(UBound(arrTem, 2) + 1, UBound(arrTem, 1) + 1) = Application.WorksheetFunction.Transpose(arrTem)End If.SaveAs fileName:=saveFolder & "\" & fileName.CloseEnd With
End Sub