本文于2023年7月15日首发于本人同名公众号：Excel活学活用，更多文章案例请搜索关注！
用户窗体-定义变量：
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 Then
Me.TxbTitle.Visible = True
Else
Me.TxbTitle.Visible = False
Me.TxbTitle = ""
End If
End Sub
代码解析：插入标题，点击勾选则显示文本框，再点击取消勾选，隐藏文本框。
用户窗体-Sub CmbFilterColumn
Private Sub CmbFilterColumn_Change()
On Error Resume Next
Dim dicFilter As Object
Set dicFilter = CreateObject("Scripting.Dictionary")
For i = 1 To lastCol
If arr(1, i) = Me.CmbFilterColumn Then
filterCol = i
Exit For
End If
Next
For i = 1 To lastCol
If arr(1, i) = Me.CmbSplitColumn Then
SplitCol = i
Exit For
End If
Next
For i = 2 To lastRow
If Me.CmbSplit = "" Then
dicFilter(arr(i, filterCol)) = 1
Else
If arr(i, SplitCol) = Me.CmbSplit Then
dicFilter(arr(i, filterCol)) = 1
End If
End If
Next
arrFilter = dicFilter.keys
Call SortArray(arrFilter)
Me.CmbInclude.List = arrFilter
Me.CmbExclude.List = arrFilter
Me.CmbInclude = ""
Me.CmbInclude = ""
End Sub
代码解析：其他筛选，改变筛选字段，重新设置其下两个复合框的List
用户窗体-Sub CmbSplit_Change
Private Sub CmbSplit_Change()
On Error Resume Next
Dim dicDate As Object
Dim dicNumber As Object
Dim dicFilter As Object
Dim strArr As String, strCmb As String
Set dicDate = CreateObject("Scripting.Dictionary")
Set dicNumber = CreateObject("Scripting.Dictionary")
Set dicFilter = CreateObject("Scripting.Dictionary")
For i = 2 To lastRow
strArr = CStr(arr(i, SplitCol))
strCmb = CStr(Me.CmbSplit)
If dateCol > 0 Then
If strArr = strCmb Then
dicDate(arr(i, dateCol)) = 1
End If
End If
If NumberCol > 0 Then
If strArr = strCmb Then
dicNumber(arr(i, NumberCol)) = 1
End If
End If
If filterCol > 0 Then
If strArr = strCmb Then
dicFilter(arr(i, filterCol)) = 1
End If
End If
Next
Me.CmbMinDate.Clear
Me.CmbMaxDate.Clear
arrDate = dicDate.keys
Call SortArray(arrDate)
Me.CmbMinDate.List = arrDate
Me.CmbMaxDate.List = arrDate
Me.CmbMinNumber.Clear
Me.CmbMaxNumber.Clear
arrNumber = dicNumber.keys
Call SortArray(arrNumber)
Me.CmbMinNumber.List = arrNumber
Me.CmbMaxNumber.List = arrNumber
Me.CmbInclude.Clear
Me.CmbExclude.Clear
arrFilter = dicFilter.keys
Call SortArray(arrFilter)
Me.CmbInclude.List = arrFilter
Me.CmbExclude.List = arrFilter
End Sub
代码解析：单选项目change事件，右边的三个筛选都要随之改变。
用户窗体-Sub CmbSplitColumn_Change
Private Sub CmbSplitColumn_Change()
'On Error Resume Next
Dim dicSplit As Object
Dim dicNumber As Object
Dim dicDate As Object
Dim dicFilter As Object
Set dicSplit = CreateObject("Scripting.Dictionary")
Set dicDate = CreateObject("Scripting.Dictionary")
Set dicNumber = CreateObject("Scripting.Dictionary")
Set dicFilter = CreateObject("Scripting.Dictionary")
For i = 1 To lastCol
If arr(1, i) = Me.CmbDateColumn Then
dateCol = i
ElseIf arr(1, i) = Me.CmbSplitColumn Then
SplitCol = i
ElseIf arr(1, i) = Me.CmbNumberColumn Then
NumberCol = i
ElseIf arr(1, i) = Me.CmbFilterColumn Then
filterCol = i
End If
Next
For i = 2 To lastRow
If SplitCol > 0 Then
dicSplit(arr(i, SplitCol)) = 1
End If
If dateCol > 0 Then
dicDate(arr(i, dateCol)) = 1
End If
If NumberCol > 0 Then
dicNumber(arr(i, NumberCol)) = 1
End If
If filterCol > 0 Then
dicFilter(arr(i, filterCol)) = 1
End If
Next
arrSplit = dicSplit.keys
Me.CmbSplit.List = dicSplit.keys
arrDate = dicDate.keys
Call SortArray(arrDate)
arrNumber = dicNumber.keys
Call SortArray(arrNumber)
arrFilter = dicFilter.keys
Call SortArray(arrFilter)
Me.CmbMinDate.List = arrDate
Me.CmbMaxDate.List = arrDate
Me.CmbMinNumber.List = arrNumber
Me.CmbMaxNumber.List = arrNumber
Me.CmbInclude.List = arrFilter
Me.CmbExclude.List = arrFilter
Me.CmbMinDate = ""
Me.CmbMaxDate = ""
Me.CmbMinNumber = ""
Me.CmbMaxNumber = ""
Me.CmbSplit = ""
End Sub
代码解析：拆分列的change事件，右边的三个筛选都随之改变。
用户窗体-Sub CmbDateColumn_Change
Private Sub CmbDateColumn_Change()
On Error Resume Next
Dim dicDate As Object
Dim arrMinDate(), arrMaxDate()
Set dicDate = CreateObject("Scripting.Dictionary")
For i = 1 To lastCol
If arr(1, i) = Me.CmbDateColumn Then
dateCol = i
Exit For
End If
Next
For i = 1 To lastCol
If arr(1, i) = Me.CmbSplitColumn Then
SplitCol = i
Exit For
End If
Next
For i = 2 To lastRow
If Me.CmbSplit = "" Then
dicDate(arr(i, dateCol)) = 1
Else
If arr(i, SplitCol) = Me.CmbSplit Then
dicDate(arr(i, dateCol)) = 1
End If
End If
Next
arrDate = dicDate.keys
Call SortArray(arrDate)
Me.CmbMinDate.List = arrDate
Me.CmbMaxDate.List = arrDate
Me.CmbMinDate = ""
Me.CmbMaxDate = ""
End Sub
代码解析：日期筛选列的change事件，其下两个筛选都随之改变。
用户窗体-Sub CmbNumberColumn_Change
Private Sub CmbNumberColumn_Change()
On Error Resume Next
Dim dicNumber As Object
Dim arrMinNumber(), arrMaxnumber()
Set dicNumber = CreateObject("Scripting.Dictionary")
For i = 1 To lastCol
If arr(1, i) = Me.CmbNumberColumn Then
NumberCol = i
Exit For
End If
Next
For i = 1 To lastCol
If arr(1, i) = Me.CmbSplitColumn Then
SplitCol = i
Exit For
End If
Next
For i = 2 To lastRow
If Me.CmbSplit = "" Then
dicNumber(arr(i, NumberCol)) = 1
Else
If arr(i, SplitCol) = Me.CmbSplit Then
dicNumber(arr(i, NumberCol)) = 1
End If
End If
Next
arrNumber = dicNumber.keys
Call SortArray(arrNumber)
Me.CmbMinNumber.List = arrNumber
Me.CmbMaxNumber.List = arrNumber
Me.CmbMinNumber = ""
Me.CmbMaxNumber = ""
End Sub
代码解析：数值筛选列的change事件。
用户窗体-Sub CmbSheets_Change
Private Sub CmbSheets_Change()
Dim ckBox As Control
Dim ctrl As Control
shtName = Me.CmbSheets
Set xlSheet = xlBook.Sheets(shtName)
Set rng = xlSheet.UsedRange
arr = rng.Value
lastRow = UBound(arr, 1)
lastCol = UBound(arr, 2)
For i = 1 To lastCol
ReDim Preserve tbTitle(1 To i)
tbTitle(i) = arr(1, i)
Next
For Each ctrl In Me.Controls
If InStr(ctrl.Name, "CheckBox_") > 0 Then
Me.Controls.Remove ctrl.Name
End If
Next
leftPos = Me.LbColumn.Left + 10 ' 左侧位置
topPos = Me.LbColumn.Top + Me.LbColumn.Height + 2 ' 复选框的顶部位置
iwidth = 70
'
For i = 1 To lastCol
Set ckBox = Me.Controls.Add("Forms.CheckBox.1", "CheckBox_" & i)
With ckBox
.Left = leftPos
.Top = topPos
.Width = iwidth
.Height = 20
.Caption = tbTitle(i)
.Value = True
End With
'更新位置
If (i) Mod 4 = 0 Then
'换行
leftPos = Me.LbColumn.Left + 10
topPos = topPos + 20
Else
'同行下一个位置
leftPos = leftPos + iwidth
End If
Next
Me.CmbSplitColumn.Clear
Me.CmbDateColumn.Clear
Me.CmbNumberColumn.Clear
Me.CmbFilterColumn.Clear
For i = 1 To lastCol
If 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 If
Next
Me.CmdSelect.Visible = True
Me.CmbDateColumn = ""
Me.CmbMinDate.Clear
Me.CmbMaxDate.Clear
Me.CmbNumberColumn = ""
Me.CmbMinNumber.Clear
Me.CmbMaxNumber.Clear
Me.CmbFilterColumn = ""
Me.CmbInclude.Clear
Me.CmbExclude.Clear
Me.CmbSplit.Clear
dateCol = 0
SplitCol = 0
With Me.CmbSplitColumn
.Clear
.List = tbTitle
.Text = .List(0)
End With
End Sub
代码解析：拆分目标工作表的change事件，窗体上的大部筛选都要重设。
用户窗体-Sub CmdChooseFile_Click
Private Sub CmdChooseFile_Click()
Set xlApp = CreateObject("Excel.Application")
Me.TxbExcelFile = FileSelected
filePath = Me.TxbExcelFile
If Not filePath = "" Then
Set xlBook = xlApp.Workbooks.Open(filePath)
Else
MsgBox "请选择文件！"
Exit Sub
End If
For Each sht In xlBook.Worksheets
If sht.Cells(1, 1) <> "" Then
Me.CmbSheets.AddItem sht.Name
End If
Next
Me.CmbSheets.Text = Me.CmbSheets.List(0)
shtName = Me.CmbSheets
End Sub
代码解析：选择拆分文件。
用户窗体-Sub CmdChoosePath_Click
Private Sub CmdChoosePath_Click()
Dim preFolder As String
preFolder = Me.TxbWordPath
If Not IsFolderExists(preFolder) Then
preFolder = ThisWorkbook.Path
End If
saveFolder = PathSelected
If Not saveFolder = "" Then
Me.TxbWordPath = saveFolder
Else
saveFolder = preFolder
Me.TxbWordPath = saveFolder
End If
End Sub
代码解析：选择保存路径。
用户窗体-Sub CmbDateColumn_Change
Private Sub CmdOutPut_Click()
On Error Resume Next
Dim arrTitle()
Dim minDate As Date, maxDate As Date
Dim minNumber As Double, maxNumber As Double
Dim strInclude As String, strExclude As String
Application.ScreenUpdating = False
filesCounter = 0
t = 0
For i = LBound(tbTitle) To UBound(tbTitle)
If Me.Controls("CheckBox_" & i) = True Then
t = 1
Exit For
End If
Next
If t = 0 Then
MsgBox "至少选择一列"
Exit Sub
End If
If Me.OptWord Then
Set wrdApp = CreateObject("Word.Application")
End If
' wrdApp.Visible = True ' 将Word应用程序设置为可见
For i = 1 To lastCol
If Controls("CheckBox_" & i) Then
ReDim Preserve arrTitle(k)
arrTitle(k) = Controls("CheckBox_" & i).Caption
k = k + 1
End If
Next
newRow = UBound(arrTitle, 1)
ReDim arrTem(0 To newRow, 0 To 0)
For i = 0 To newRow
arrTem(i, 0) = arrTitle(i)
Next
'日期范围
If Me.CmbDateColumn <> "" Then
If Me.CmbMinDate = "" Then
minDate = arrDate(LBound(arrDate))
Else
minDate = CDate(Me.CmbMinDate)
End If
If Me.CmbMaxDate = "" Then
maxDate = arrDate(UBound(arrDate))
Else
maxDate = CDate(Me.CmbMaxDate)
End If
End If
'金额范围
If Me.CmbNumberColumn <> "" Then
If Me.CmbMinNumber = "" Then
minNumber = CDbl(arrNumber(LBound(arrNumber)))
Else
minNumber = CDbl(Me.CmbMinNumber)
End If
If Me.CmbMaxNumber = "" Then
maxNumber = CDbl(arrNumber(UBound(arrNumber)))
Else
maxNumber = CDbl(Me.CmbMaxNumber)
End If
End If
'筛选字段
If Me.CmbFilterColumn <> "" Then
If Me.CmbInclude = "" Then
strInclude = ""
Else
strInclude = CStr(Me.CmbInclude)
End If
If Me.CmbExclude = "" Then
strExclude = "1234567890qwertyuiop"
Else
strExclude = CStr(Me.CmbExclude)
End If
End If
If Me.CmbSplitColumn = "" Then '客户为空
MsgBox "拆分字段不能为空"
Exit Sub
End If
If Me.CmbSplit = "" Then '未选具体拆分项目 第一层IF
If Me.CmbDateColumn = "" Then '未选日期列 第二层IF
If Me.CmbNumberColumn = "" Then '未选数值列 第三层IF
If Me.CmbFilterColumn = "" Then '未选筛选列 第四层IF
For i = LBound(arrSplit) To UBound(arrSplit)
For j = 2 To lastRow
If arr(j, SplitCol) = arrSplit(i) Then
m = UBound(arrTem, 2) + 1
ReDim Preserve arrTem(0 To newRow, 0 To m)
For k = 0 To newRow
For n = 1 To lastCol
If arr(1, n) = arrTem(k, 0) Then
arrTem(k, m) = arr(j, n)
End If
Next
Next
End If
Next
fileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
fileName = Replace(fileName, "\", "_")
fileName = Replace(fileName, "/", "_")
Call SaveToFile
ReDim Preserve arrTem(0 To newRow, 0 To 0)
' Stop
Next
Else '选了筛选列 e1 第四层IF else
For i = LBound(arrSplit) To UBound(arrSplit)
For j = 2 To lastRow
If arr(j, SplitCol) = arrSplit(i) And InStr(arr(j, filterCol), strInclude) > 0 _
And InStr(arr(j, filterCol), strExclude) = 0 Then
m = UBound(arrTem, 2) + 1
ReDim Preserve arrTem(0 To newRow, 0 To m)
For k = 0 To newRow
For n = 1 To lastCol
If arr(1, n) = arrTem(k, 0) Then
arrTem(k, m) = arr(j, n)
End If
Next
Next
End If
Next
fileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
fileName = Replace(fileName, "\", "_")
fileName = Replace(fileName, "/", "_")
Call SaveToFile
ReDim Preserve arrTem(0 To newRow, 0 To 0)
Next
End If '第四层IF end
Else '选了数值列 第三层IF else
If Me.CmbFilterColumn = "" Then '未选筛选列
For i = LBound(arrSplit) To UBound(arrSplit)
For j = 2 To lastRow
If arr(j, SplitCol) = arrSplit(i) And CDbl(arr(j, NumberCol)) >= minNumber _
And CDbl(arr(j, NumberCol)) <= maxNumber Then
m = UBound(arrTem, 2) + 1
ReDim Preserve arrTem(0 To newRow, 0 To m)
For k = 0 To newRow
For n = 1 To lastCol
If arr(1, n) = arrTem(k, 0) Then
arrTem(k, m) = arr(j, n)
End If
Next
Next
End If
Next
fileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
fileName = Replace(fileName, "\", "_")
fileName = Replace(fileName, "/", "_")
Call SaveToFile
ReDim Preserve arrTem(0 To newRow, 0 To 0)
Next
Else '选了筛选列 E3
For i = LBound(arrSplit) To UBound(arrSplit)
For j = 2 To lastRow
If 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 Then
m = UBound(arrTem, 2) + 1
ReDim Preserve arrTem(0 To newRow, 0 To m)
For k = 0 To newRow
For n = 1 To lastCol
If arr(1, n) = arrTem(k, 0) Then
arrTem(k, m) = arr(j, n)
End If
Next
Next
End If
Next
fileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
fileName = Replace(fileName, "\", "_")
fileName = Replace(fileName, "/", "_")
Call SaveToFile
ReDim Preserve arrTem(0 To newRow, 0 To 0)
Next
End If
End If '第三层IF end
Else '第二层IF else 选择了日期列
If Me.CmbNumberColumn = "" Then '选择了日期列，未选数值列
If Me.CmbFilterColumn = "" Then '选择了日期列，未选数值列,未选筛选列
For i = LBound(arrSplit) To UBound(arrSplit)
For j = 2 To lastRow
If arr(j, SplitCol) = arrSplit(i) And CDate(arr(j, dateCol)) >= minDate _
And CDate(arr(j, dateCol)) <= maxDate Then
m = UBound(arrTem, 2) + 1
ReDim Preserve arrTem(0 To newRow, 0 To m)
For k = 0 To newRow
For n = 1 To lastCol
If arr(1, n) = arrTem(k, 0) Then
arrTem(k, m) = arr(j, n)
End If
Next
Next
End If
Next
fileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
fileName = Replace(fileName, "\", "_")
fileName = Replace(fileName, "/", "_")
Call SaveToFile
ReDim Preserve arrTem(0 To newRow, 0 To 0)
Next
Else ' '选择了日期列，未选数值列,选了筛选列
For i = LBound(arrSplit) To UBound(arrSplit)
For j = 2 To lastRow
If 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 Then
m = UBound(arrTem, 2) + 1
ReDim Preserve arrTem(0 To newRow, 0 To m)
For k = 0 To newRow
For n = 1 To lastCol
If arr(1, n) = arrTem(k, 0) Then
arrTem(k, m) = arr(j, n)
End If
Next
Next
End If
Next
fileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
fileName = Replace(fileName, "\", "_")
fileName = Replace(fileName, "/", "_")
Call SaveToFile
ReDim Preserve arrTem(0 To newRow, 0 To 0)
Next
End If
Else '选择了日期列，选了数值列
If Me.CmbFilterColumn = "" Then '选择了日期列，选了数值列,未选筛选列
For i = LBound(arrSplit) To UBound(arrSplit)
For j = 2 To lastRow
If 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 Then
m = UBound(arrTem, 2) + 1
ReDim Preserve arrTem(0 To newRow, 0 To m)
For k = 0 To newRow
For n = 1 To lastCol
If arr(1, n) = arrTem(k, 0) Then
arrTem(k, m) = arr(j, n)
End If
Next
Next
End If
Next
fileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
fileName = Replace(fileName, "\", "_")
fileName = Replace(fileName, "/", "_")
Call SaveToFile
ReDim Preserve arrTem(0 To newRow, 0 To 0)
Next
Else '选择了日期列，选了数值列,选了筛选列
For i = LBound(arrSplit) To UBound(arrSplit)
For j = 2 To lastRow
If 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 Then
m = UBound(arrTem, 2) + 1
ReDim Preserve arrTem(0 To newRow, 0 To m)
For k = 0 To newRow
For n = 1 To lastCol
If arr(1, n) = arrTem(k, 0) Then
arrTem(k, m) = arr(j, n)
End If
Next
Next
End If
Next
fileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
fileName = Replace(fileName, "\", "_")
fileName = Replace(fileName, "/", "_")
Call SaveToFile
ReDim Preserve arrTem(0 To newRow, 0 To 0)
Next
End If
End If
End If
Else '选择了具体拆分项目
If Me.CmbDateColumn = "" Then '未选日期列 第二层IF
If Me.CmbNumberColumn = "" Then '未选数值列 第三层IF
If Me.CmbFilterColumn = "" Then '未选筛选列 第四层IF
For j = 2 To lastRow
If arr(j, SplitCol) = Me.CmbSplit Then
m = UBound(arrTem, 2) + 1
ReDim Preserve arrTem(0 To newRow, 0 To m)
For k = 0 To newRow
For n = 1 To lastCol
If arr(1, n) = arrTem(k, 0) Then
arrTem(k, m) = arr(j, n)
End If
Next
Next
End If
Next
fileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
fileName = Replace(fileName, "\", "_")
fileName = Replace(fileName, "/", "_")
Call SaveToFile
ReDim Preserve arrTem(0 To newRow, 0 To 0)
Else '选了筛选列 e1 第四层IF else
For j = 2 To lastRow
If arr(j, SplitCol) = Me.CmbSplit And InStr(arr(j, filterCol), strInclude) > 0 _
And InStr(arr(j, filterCol), strExclude) = 0 Then
m = UBound(arrTem, 2) + 1
ReDim Preserve arrTem(0 To newRow, 0 To m)
For k = 0 To newRow
For n = 1 To lastCol
If arr(1, n) = arrTem(k, 0) Then
arrTem(k, m) = arr(j, n)
End If
Next
Next
End If
Next
fileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
fileName = Replace(fileName, "\", "_")
fileName = Replace(fileName, "/", "_")
Call SaveToFile
ReDim Preserve arrTem(0 To newRow, 0 To 0)
End If '第四层IF end
Else '选了数值列 第三层IF else
If Me.CmbFilterColumn = "" Then '未选筛选列
For j = 2 To lastRow
If arr(j, SplitCol) = Me.CmbSplit And CDbl(arr(j, NumberCol)) >= minNumber _
And CDbl(arr(j, NumberCol)) <= maxNumber Then
m = UBound(arrTem, 2) + 1
ReDim Preserve arrTem(0 To newRow, 0 To m)
For k = 0 To newRow
For n = 1 To lastCol
If arr(1, n) = arrTem(k, 0) Then
arrTem(k, m) = arr(j, n)
End If
Next
Next
End If
Next
fileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
fileName = Replace(fileName, "\", "_")
fileName = Replace(fileName, "/", "_")
Call SaveToFile
ReDim Preserve arrTem(0 To newRow, 0 To 0)
Else '选了筛选列 E3
For j = 2 To lastRow
If 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 Then
m = UBound(arrTem, 2) + 1
ReDim Preserve arrTem(0 To newRow, 0 To m)
For k = 0 To newRow
For n = 1 To lastCol
If arr(1, n) = arrTem(k, 0) Then
arrTem(k, m) = arr(j, n)
End If
Next
Next
End If
Next
fileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
fileName = Replace(fileName, "\", "_")
fileName = Replace(fileName, "/", "_")
Call SaveToFile
ReDim Preserve arrTem(0 To newRow, 0 To 0)
End If
End If '第三层IF end
Else '第二层IF else 选择了日期列
If Me.CmbNumberColumn = "" Then '选择了日期列，未选数值列
If Me.CmbFilterColumn = "" Then '选择了日期列，未选数值列,未选筛选列
For j = 2 To lastRow
If arr(j, SplitCol) = Me.CmbSplit And CDate(arr(j, dateCol)) >= minDate _
And CDate(arr(j, dateCol)) <= maxDate Then
m = UBound(arrTem, 2) + 1
ReDim Preserve arrTem(0 To newRow, 0 To m)
For k = 0 To newRow
For n = 1 To lastCol
If arr(1, n) = arrTem(k, 0) Then
arrTem(k, m) = arr(j, n)
End If
Next
Next
End If
Next
fileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
fileName = Replace(fileName, "\", "_")
fileName = Replace(fileName, "/", "_")
Call SaveToFile
ReDim Preserve arrTem(0 To newRow, 0 To 0)
Else ' '选择了日期列，未选数值列,选了筛选列
For j = 2 To lastRow
If 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 Then
m = UBound(arrTem, 2) + 1
ReDim Preserve arrTem(0 To newRow, 0 To m)
For k = 0 To newRow
For n = 1 To lastCol
If arr(1, n) = arrTem(k, 0) Then
arrTem(k, m) = arr(j, n)
End If
Next
Next
End If
Next
fileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
fileName = Replace(fileName, "\", "_")
fileName = Replace(fileName, "/", "_")
Call SaveToFile
ReDim Preserve arrTem(0 To newRow, 0 To 0)
End If
Else '选择了日期列，选了数值列
If Me.CmbFilterColumn = "" Then '选择了日期列，选了数值列,未选筛选列
For j = 2 To lastRow
If 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 Then
m = UBound(arrTem, 2) + 1
ReDim Preserve arrTem(0 To newRow, 0 To m)
For k = 0 To newRow
For n = 1 To lastCol
If arr(1, n) = arrTem(k, 0) Then
arrTem(k, m) = arr(j, n)
End If
Next
Next
End If
Next
fileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
fileName = Replace(fileName, "\", "_")
fileName = Replace(fileName, "/", "_")
Call SaveToFile
ReDim Preserve arrTem(0 To newRow, 0 To 0)
Else '选择了日期列，选了数值列,选了筛选列
For j = 2 To lastRow
If 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 Then
m = UBound(arrTem, 2) + 1
ReDim Preserve arrTem(0 To newRow, 0 To m)
For k = 0 To newRow
For n = 1 To lastCol
If arr(1, n) = arrTem(k, 0) Then
arrTem(k, m) = arr(j, n)
End If
Next
Next
End If
Next
fileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
fileName = Replace(fileName, "\", "_")
fileName = Replace(fileName, "/", "_")
Call SaveToFile
ReDim Preserve arrTem(0 To newRow, 0 To 0)
End If
End If
End If
End If
MsgBox "成功拆分【" & filesCounter & "】个文件"
'打开拆分文件所在目录
Shell "explorer.exe " & saveFolder, vbMaximizedFocus
On Error Resume Next
If Not xlBook Is Nothing Then
'工作簿已打开，执行关闭
xlBook.Close False
End If
wrdApp.Quit
xlApp.Quit
Set wrdTable = Nothing
Set wrdDoc = Nothing
Set wrdApp = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
Unload Me
Application.ScreenUpdating = True
End Sub
代码解析：导出文件
1、如果没有选择“单选项目”，则会将拆分列的所有项目拆分为单独文件。
2、循环拆分项目，根据右边筛选条件，提取数据，存到数据，导出到文件。
3、代码量主要在选择判断方面。
用户窗体-其他代码
Private Sub CmdSelect_Click()
If Me.CmdSelect.Caption = "全选" Then
For i = LBound(tbTitle) To UBound(tbTitle)
Me.Controls("CheckBox_" & i) = True
Next
Me.CmdSelect.Caption = "全消"
Me.CmdSelect.BackColor = &HC0FFC0
Else
For i = LBound(tbTitle) To UBound(tbTitle)
Me.Controls("CheckBox_" & i) = False
Next
Me.CmdSelect.Caption = "全选"
Me.CmdSelect.BackColor = &H8080FF
End If
End Sub
Private Sub OptExcel_Change()
If OptExcel Then
Me.OptExcel.ForeColor = vbRed
Me.OptWord.ForeColor = vbBlue
Else
Me.OptExcel.ForeColor = vbBlue
Me.OptWord.ForeColor = vbRed
End If
End Sub
Private Sub UserForm_Initialize()
saveFolder = ThisWorkbook.Path
Me.TxbWordPath = saveFolder
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
If Not xlBook Is Nothing Then
'工作簿已打开，执行关闭
xlBook.Close False
End If
wrdApp.Quit
xlApp.Quit
Set wrdTable = Nothing
Set wrdDoc = Nothing
Set wrdApp = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End Sub
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.OptExcel Then
Call SaveToExcel
Else
Call SaveToWord
End If
End Sub
Sub SaveToWord()
'Stop
'创建新的Word文档
Set wrdDoc = wrdApp.Documents.Add
Set myrange = wrdDoc.Range(0, 0)
With myrange
.InsertBefore Me.TxbTitle & vbCrLf
With .Font
.Name = "黑体"
.Size = 16
'.Bold = True
End With
'.ParagraphFormat.Alignment = wdAlignParagraphCenter
'.InsertParagraphAfter
.Collapse Direction:=wdCollapseEnd
End With
With wrdDoc.Paragraphs(1)
.Alignment = wdAlignParagraphCenter
End With
'添加新的表格
Set wrdTable = wrdDoc.Tables.Add(myrange, UBound(arrTem, 2) + 1, newRow + 1)
'设置表格边框格式为灰色虚线
With wrdTable
.Style = "网格型"
End With
For c = 1 To UBound(arrTem, 2) + 1
For d = 1 To newRow + 1
wrdTable.Cell(c, d).Range.Text = arrTem(d - 1, c - 1)
Next
Next
wrdDoc.SaveAs saveFolder & "\" & fileName
wrdDoc.Close SaveChanges:=False
End Sub
Sub SaveToExcel()
'原来导出的是word文件，扩展名改一下
fileName = Replace(fileName, ".docx", ".xlsx")
Workbooks.Add
With ActiveWorkbook
If 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
.Close
End With
End Sub
正文完
喜欢就点个赞、留个言呗！