本文于2023年7月11日首发于本人同名其他平台，更多文章案例请搜索关注！
用户窗体-定义变量：有点变量可能没有用到，暂时也不管理它了。
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 rowIndex As Long
Dim rowCount As Long
Dim colIndex As Long
Dim colCount As Long
Dim selectedCols As Variant
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(), arrCustomer()
Dim customerCol As Integer
Dim dateCol As Integer
Dim arrTem()
Dim newRow As Integer
用户窗体-Sub CmbCustomer_Change
Private Sub CmbCustomer_Change()
On Error Resume Next
Dim dicDate As Object
Set dicDate = CreateObject("Scripting.Dictionary")
If dateCol > 0 Then
For i = 2 To lastRow
If arr(i, customerCol) = Me.CmbCustomer Then
dicDate(arr(i, dateCol)) = 1
End If
Next
End If
Me.CmbBeginDate.Clear
Me.CmbEndDate.Clear
arrDate = dicDate.keys
Call SortArray(arrDate)
Me.CmbBeginDate.List = arrDate
Me.CmbEndDate.List = arrDate
End Sub
用户窗体-Sub CmbCustomerColumn_Change
Private Sub CmbCustomerColumn_Change()
On Error Resume Next
Dim dicCustomer As Object
Dim dicDate As Object
Set dicCustomer = CreateObject("Scripting.Dictionary")
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.CmbCustomerColumn Then
customerCol = i
Exit For
End If
Next
For i = 2 To lastRow
If customerCol > 0 Then
dicCustomer(arr(i, customerCol)) = 1
End If
If dateCol > 0 Then
dicDate(arr(i, dateCol)) = 1
End If
Next
arrCustomer = dicCustomer.keys
Me.CmbCustomer.List = dicCustomer.keys
arrDate = dicDate.keys
Call SortArray(arrDate)
Me.CmbBeginDate.List = arrDate
Me.CmbEndDate.List = arrDate
Me.CmbBeginDate = ""
Me.CmbEndDate = ""
Me.CmbCustomer = ""
End Sub
用户窗体-Sub CmbDateColumn_Change
Private Sub CmbDateColumn_Change()
On Error Resume Next
Dim dicDate As Object
Dim arrBeginDate(), arrEndDate()
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.CmbCustomerColumn Then
customerCol = i
Exit For
End If
Next
For i = 2 To lastRow
If Me.CmbCustomer = "" Then
dicDate(arr(i, dateCol)) = 1
Else
If arr(i, customerCol) = Me.CmbCustomer Then
dicDate(arr(i, dateCol)) = 1
End If
End If
Next
arrDate = dicDate.keys
Call SortArray(arrDate)
Me.CmbBeginDate.List = arrDate
Me.CmbEndDate.List = arrDate
Me.CmbBeginDate = ""
Me.CmbEndDate = ""
End Sub
用户窗体-Sub CmbSheets_Change
Private Sub CmbSheets_Change()
Dim ckBox As Control
Dim ctrl As Control
Dim tbTitle()
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
Me.CmbCustomerColumn.Clear
Me.CmbCustomerColumn.List = tbTitle
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 8 = 0 Then
'换行
leftPos = Me.LbColumn.Left + 10
topPos = topPos + 20
Else
'同行下一个位置
leftPos = leftPos + iwidth
End If
Next
Me.CmbCustomerColumn.Clear
Me.CmbCustomerColumn.List = tbTitle
Me.CmbDateColumn.Clear
For i = 1 To lastCol
If IsDate(arr(2, i)) Then
Me.CmbDateColumn.AddItem arr(1, i)
End If
Next
Me.CmbDateColumn = ""
Me.CmbCustomerColumn.List = tbTitle
Me.CmbBeginDate.Clear
Me.CmbEndDate.Clear
Me.CmbCustomer.Clear
dateCol = 0
customerCol = 0
End Sub
用户窗体-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()
saveFolder = PathSelected
Me.TxbWordPath = saveFolder
End Sub
用户窗体-Sub CmdOutPut_Click
Private Sub CmdOutPut_Click()
Dim arrTitle()
Set wrdApp = CreateObject("Word.Application")
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.CmbCustomerColumn = "" Then
If Me.CmbBeginDate = "" Or Me.CmbEndDate = "" Or CDate(Me.CmbBeginDate) > CDate(Me.CmbEndDate) Then
MsgBox "请正确选择起止日期"
Exit Sub
End If
For j = 2 To lastRow
If CDate(arr(j, dateCol)) >= CDate(Me.CmbBeginDate) And CDate(arr(j, dateCol)) <= CDate(Me.CmbEndDate) 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 = Format(Me.CmbBeginDate, "YYYYMMDD") & "To" & Format(Me.CmbEndDate, "YYYYMMDD") & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
Call SaveToWord
ReDim Preserve arrTem(0 To newRow, 0 To 0)
Exit Sub
ElseIf Me.CmbDateColumn = "" Then
MsgBox "请选择日期列"
Exit Sub
ElseIf Me.TxbWordPath = "" Then
MsgBox "请选择文件保存位置"
Exit Sub
End If
If Me.CmbCustomer = "" Then '客户为空
If Me.CmbBeginDate = "" Then '开始日期为空
If Me.CmbEndDate = "" Then '结束日期为空
For i = LBound(arrCustomer) To UBound(arrCustomer)
For j = 2 To lastRow
If arr(j, customerCol) = arrCustomer(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 = arrCustomer(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
Call SaveToWord
ReDim Preserve arrTem(0 To newRow, 0 To 0)
Next
Else '结束日期不为空
For i = LBound(arrCustomer) To UBound(arrCustomer)
For j = 2 To lastRow
If arr(j, customerCol) = arrCustomer(i) And CDate(arr(j, dateCol)) <= CDate(Me.CmbEndDate) 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 = arrCustomer(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
Call SaveToWord
ReDim Preserve arrTem(0 To newRow, 0 To 0)
Next
End If
Else '开始日期不为空
If Me.CmbEndDate = "" Then '开始日期不为空，但结束日期为空
For i = LBound(arrCustomer) To UBound(arrCustomer)
For j = 2 To lastRow
If arr(j, customerCol) = arrCustomer(i) And CDate(arr(j, dateCol)) >= CDate(Me.CmbBeginDate) 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 = arrCustomer(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
Call SaveToWord
ReDim Preserve arrTem(0 To newRow, 0 To 0)
Next
Else
If CDate(Me.CmbBeginDate) > CDate(Me.CmbEndDate) Then
MsgBox "起始始日期不能大于结束日期"
Exit Sub
End If
For i = LBound(arrCustomer) To UBound(arrCustomer)
For j = 2 To lastRow
If arr(j, customerCol) = arrCustomer(i) And CDate(arr(j, dateCol)) >= CDate(Me.CmbBeginDate) And CDate(arr(j, dateCol)) <= CDate(Me.CmbEndDate) 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 = arrCustomer(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
Call SaveToWord
ReDim Preserve arrTem(0 To newRow, 0 To 0)
Next
End If
End If
Else '客户不为空
If Me.CmbBeginDate = "" Then '起始日期为空
If Me.CmbEndDate = "" Then '结束日期为空
For j = 2 To lastRow
If arr(j, customerCol) = Me.CmbCustomer 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.CmbCustomer & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
Call SaveToWord
ReDim Preserve arrTem(0 To newRow, 0 To 0)
Else '起始日期为空，结束日期不为空
For j = 2 To lastRow
If arr(j, customerCol) = Me.CmbCustomer And CDate(arr(j, dateCol)) <= CDate(Me.CmbEndDate) 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.CmbCustomer & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
Call SaveToWord
ReDim Preserve arrTem(0 To newRow, 0 To 0)
End If
Else
If Me.CmbEndDate = "" Then
For j = 2 To lastRow
If arr(j, customerCol) = Me.CmbCustomer And CDate(arr(j, dateCol)) >= CDate(Me.CmbBeginDate) 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.CmbCustomer & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
Call SaveToWord
ReDim Preserve arrTem(0 To newRow, 0 To 0)
Else
For j = 2 To lastRow
If arr(j, customerCol) = Me.CmbCustomer And CDate(arr(j, dateCol)) >= CDate(Me.CmbBeginDate) And CDate(arr(j, dateCol)) <= CDate(Me.CmbEndDate) 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.CmbCustomer & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
Call SaveToWord
ReDim Preserve arrTem(0 To newRow, 0 To 0)
End If
End If
End If
End Sub
用户窗体-Sub UserForm_QueryClose
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
用户窗体-SaveToWord
'把结果写入WORD表的过程，对WORD的操作没有搞得明白，比如文字标题居中中，
'在网上查了代码，不起作用，不影响大局，先不管它了。
Sub SaveToWord()
'创建新的Word文档
Set wrdDoc = wrdApp.Documents.Add
'在Word文档中添加标题
'wrdDoc.Content.InsertAfter "贷款明细表" & vbCrLf & vbCrLf
'Set myrange = wrdDoc.Content
Set myrange = wrdDoc.Range(0, 0)
With myrange
.InsertBefore "贷款明细表" & 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
模块1-几个自定义函数
Function PathSelected()
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path
If .Show = -1 Then 'FileDialog 对象的 Show 方法显示对话框
PathSelected = .SelectedItems(1)
Else
Exit Function
End If
End With
End Function
Function FileSelected()
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False '单选择
.Filters.Clear '清除文件过滤器
.Filters.Add "Excel Files", "*.xlsm;*.xlsx;*.xls" '设置两个文件过滤器
.Filters.Add "All Files", "*.*"
.InitialFileName = ThisWorkbook.Path & "\.xlsx"
If .Show = -1 Then 'FileDialog 对象的 Show 方法显示对话框，并且返回 -1或0。
FileSelected = .SelectedItems(1)
Else
Exit Function
End If
End With
End Function
Sub SortArray(myArray)
Dim i As Long, j As Long
Dim temp As Variant
' 将数组元素转换为日期格式
For i = LBound(myArray) To UBound(myArray)
myArray(i) = CDate(myArray(i))
Next
' 使用冒泡排序算法对数组按日期进行升序排序
For i = LBound(myArray) To UBound(myArray) - 1
For j = i + 1 To UBound(myArray)
If myArray(j) < myArray(i) Then
temp = myArray(i)
myArray(i) = myArray(j)
myArray(j) = temp
End If
Next
Next
end Sub
结语
代码量还是比较大的，总体来讲不复杂，主要是选项太多，组合起来判断各种条件情况比较麻烦，真是一个体力活，我也实在不想写代码解析了，大家随便看看吧。