本文于2023年6月17日首发于本人同名公众号：Excel活学活用，更多文章案例请搜索关注！
☆本期内容概要☆
代码
Usf_VoucherList的UserForm_Activate代码，因为是从别的程序中复制过来的，可能存在一些冗余甚至错误代码，暂时先不管它了，窗体能正常启动就好。
Private Sub UserForm_Activate()
'On Error Resume Next
Dim DicMonth As Object
Dim LvItem As ListItem
Dim sData()
Dim arrTemp()
Dim sql1 As String, sql2 As String
myDataFile = ThisWorkbook.Path & "\收费管理系统数据库.accdb"
Company = GetInformation("Company")
'Stop
Me.CmdUp.Height = Me.CmbMonth.Height / 2
Me.CmdUp.Top = Me.CmbMonth.Top
Me.CmdUp.Left = Me.CmbMonth.Left + Me.CmbMonth.Width
Me.CmdDown.Height = Me.CmdUp.Height
Me.CmdDown.Top = Me.CmdUp.Top + Me.CmdUp.Height
Me.CmdDown.Left = Me.CmdUp.Left
Set DicMonth = CreateObject("Scripting.Dictionary")
Me.BackColor = RGB(218, 165, 32)
Me.CmdSelectAll.Visible = True
Me.CmdSelectAll.BackColor = RGB(143, 188, 143)
Me.CmdPrint.Visible = True
Me.Caption = tempValue
Me.LbTitle.Caption = tempValue
sql1 = "select * from tb收费明细 where ID in " _
& "(select min(ID) from tb收费明细 group by 单号) order by 单号"
sql2 = "select 日期,单号,sum(金额) as 金额 from tb收费明细 group by 日期,单号"
SQL = "select a.日期,a.单号,a.客户,a.渠道,a.科室,a.医生,b.金额,a.月份 from (" _
& sql1 & ") as a left join (" & sql2 & ") as b " _
& "on a.日期 = b.日期 and a.单号 = b.单号" _
& " order by a.月份,a.单号"
If tempValue = "收费单查询" Then
Me.CmdPrint.Visible = False
End If
arrTemp = GetData(myDataFile, sql1)
Debug.Print SQL
aData = GetData(myDataFile, SQL)
sTbtitle = GetFields(myDataFile, SQL)
PosMonth = Pxy(sTbtitle, "月份") - 1
PosNumber = Pxy(sTbtitle, "凭证号") - 1
For i = 0 To UBound(sTbtitle, 1)
With Me.LvVoucherList
If i = 0 Then
.ColumnHeaders.Add , , sTbtitle(i), 90
ElseIf i = 1 Then
.ColumnHeaders.Add , , sTbtitle(i), 100, lvwColumnCenter
ElseIf i = 2 Then
.ColumnHeaders.Add , , sTbtitle(i), 80, lvwColumnCenter
Else
.ColumnHeaders.Add , , sTbtitle(i), 70, lvwColumnCenter
End If
End With
Next
With Me.LvDetail
.View = lvwReport 'listview控件的显示外观
.Gridlines = True '是否有表格线，True有表格线
'.Sorted = True
'.CheckBoxes = True
.LabelEdit = lvwManual
.FullRowSelect = True
.ForeColor = vbBlue
End With
With Me.LvVoucherList
.View = lvwReport 'listview控件的显示外观
.Gridlines = True '是否有表格线，True有表格线
.Sorted = True
.CheckBoxes = True
.LabelEdit = lvwManual
.FullRowSelect = True
End With
'Stop
iRow = UBound(aData, 2)
iCol = UBound(aData, 1)
p = Pxy(sTbtitle, "月份")
For i = 0 To iRow
DicMonth(aData(p - 1, i)) = 1
Next
With Me.CmbMonth
.List = DicMonth.keys
.Style = fmStyleDropDownList
.Text = .List(.ListCount - 1)
End With
Me.LvVoucherList.ListItems.Clear
For i = 0 To iRow
If aData(Pxy(sTbtitle, "月份") - 1, i) = Me.CmbMonth Then
Set LvItem = Me.LvVoucherList.ListItems.Add
LvItem.Text = Format(aData(0, i), "YYYY/MM/DD")
For j = 1 To iCol
'If j = 2 Then
'LvItem.SubItems(j) = Format(aData(j, i), "Standard")
'Else
LvItem.SubItems(j) = aData(j, i)
'End If
Next
End If
Next
SQL = "select top 1 * from tb收费明细"
tbTitle = GetFields(myDataFile, SQL)
For i = 0 To UBound(tbTitle, 1)
With Me.LvDetail
If i = 0 Then
.ColumnHeaders.Add , , tbTitle(i), 30
ElseIf i = 2 Then
.ColumnHeaders.Add , , tbTitle(i), 80, lvwColumnCenter
ElseIf i = Pxy(tbTitle, "收费项目") - 1 Then
.ColumnHeaders.Add , , tbTitle(i), 120
Else
.ColumnHeaders.Add , , tbTitle(i), 70, lvwColumnCenter
End If
End With
Next
End Sub
LvVoucherList的ItemClick代码，用来查询当前点击项目的明细记录。
Private Sub LvVoucherList_ItemClick(ByVal Item As MSComctlLib.ListItem)
Dim iRw As Integer, iCo As Integer
On Error Resume Next
Item.Checked = Not Item.Checked
If Me.LvVoucherList.ListItems.Count = 0 Then
Exit Sub
End If
Me.LvDetail.ListItems.Clear
n = Me.LvVoucherList.SelectedItem.SubItems(1)
SQL = "select * from tb收费明细 where 单号= '" & n & "' order by ID"
dData = GetData(myDataFile, SQL)
iRw = UBound(dData, 2)
iCo = UBound(dData, 1)
Me.LvDetail.ListItems.Clear
For i = 0 To iRw
Set LvItem = Me.LvDetail.ListItems.Add
LvItem.Text = dData(0, i)
LvItem.ForeColor = Me.LvVoucherList.SelectedItem.ForeColor
For j = 1 To iCo
If j = Pxy(tbTitle, "金额") - 1 Then
LvItem.SubItems(j) = Format(dData(j, i), "Standard")
Else
LvItem.SubItems(j) = dData(j, i)
End If
LvItem.ListSubItems(j).ForeColor = Me.LvVoucherList.SelectedItem.ListSubItems(1).ForeColor
Next
Next
'Stop
End Sub
导出按钮
Private Sub CmdOutPut_Click()
Dim k As Integer
For i = 1 To Me.LvVoucherList.ListItems.Count
If Me.LvVoucherList.ListItems(i).Checked = True Then
k = k + 1
End If
Next
If k = 0 Then
MsgBox "请至少勾选一条记录！"
Exit Sub
End If
If Not wContinue("即将导出数据！") Then Exit Sub
On Error Resume Next
Dim arrT()
Dim iPath As String
Dim iSheet As Worksheet
iPath = ThisWorkbook.Path & "\"
fName = Company & "（" & Me.CmbMonth & "）" & Me.LbTitle & Format(VBA.Now, "YYYYMMDDhhmmss") & ".xlsx"
Application.DisplayAlerts = False
iRow = Me.LvVoucherList.ListItems.Count + 1
iCol = Me.LvVoucherList.ColumnHeaders.Count
ReDim arrT(1 To k + 1, 1 To iCol)
For i = 1 To iCol
arrT(1, i) = Me.LvVoucherList.ColumnHeaders(i)
Next
H = 2
For i = 2 To iRow
If Me.LvVoucherList.ListItems(i - 1).Checked = True Then
arrT(H, 1) = Me.LvVoucherList.ListItems(i - 1).Text
For j = 2 To iCol
arrT(H, j) = Me.LvVoucherList.ListItems(i - 1).SubItems(j - 1)
Next
H = H + 1
End If
Next
Workbooks.Add
ActiveWorkbook.Sheets(1).Range("A1").Resize(k + 1, iCol) = arrT
ActiveWorkbook.SaveAs Filename:=iPath & fName
ActiveWorkbook.Close
MsgBox ("成功导出文件" & iPath & fName)
Unload Me
Application.DisplayAlerts = True
End Sub
这里对导出方式作了修改，在前面分享过的文件中，导出可能是全部导出，这里我们把它修改为按选中的记录导出。
好，今天就这样吧。欢迎点赞、留言、分享，谢谢大家，我们下期再会。