本文于2023年7月27日首发于本人同名公众号：Excel活学活用，更多文章案例请搜索关注！
内容提要
根据债券交易明细生成审批表
用户窗体
单元格部分文字颜色设置
大家好，我是冷水泡茶，前两天有位粉丝朋友可能是看了我的文章【批量复制单元格区域、连续生成打印模板】，在我企业微信发了一个需求：
我看了一下，他的需求是这样的:
1、有一张明细表，登记了债券交易的明细记录，字段很多：
2、有一张模板，用来打印审批表：
3、经过沟通，确定具体需求是这样子的：
经过分析，基本能够实现他的需求，抽点时候做了，目前初步完工，我们一起来看看吧：
解决思路
1、文字中部分关键字，债券种类、买卖方向、金额、余额设置相应变量、控件等来提取、保存。
2、债券明细信息，可以根据关键字筛选出来。
3、债券交易明细数据如果超过当前预设的行数，则需要插入，如果有超过预设行数的空白行，则需要删除。
4、打印格式，可以在EXCEL中设置好，可不通过代码来完成。
5、设置一个用户窗体，放上需要的关键字段供选择。
实现过程
1、建立用户窗体：UserForm1，在其上放置必要的控件如下：
2、编写代码：
（1）定义公众变量
Dim arrDetail(), arrDate(), arrType(), arrDirectionDim iRow As LongDim iCol As LongDim AllBonds As Double, BankBonds As Double, BankBondsRateDim DicTransaction As ObjectDim DatePos As Integer, TypePos As IntegerDim DirectionPos As Integer, BalancePos As IntegerDim AmountPos As Integer可能有些变量是没有用到的。暂时不去管它我们先把代码跑通再说。
（2）窗体初始化代码：
Private Sub UserForm_Initialize() Dim ws As Worksheet Dim DicDate As Object Dim lastRow As Integer, lastCol As Integer Set ws = ThisWorkbook.Sheets("明细表") Set DicDate = CreateObject("Scripting.Dictionary") ws.Activate lastRow = ws.UsedRange.Rows.Count lastCol = ws.UsedRange.Columns.Count arrDetail = ws.Range(Cells(3, 1), Cells(lastRow, lastCol)).Value iRow = UBound(arrDetail, 1) iCol = UBound(arrDetail, 2) DatePos = pxy("认购日期", arrDetail, "Col", 1) TypePos = pxy("债券种类", arrDetail, "Col", 1) DirectionPos = pxy("买卖方向", arrDetail, "Col", 1) BalancePos = pxy("余额", arrDetail, "Col", 1) AmountPos = pxy("金额", arrDetail, "Col", 1) 'Stop For i = 2 To iRow If arrDetail(i, DatePos) <> "" Then DicDate(CDate(arrDetail(i, DatePos))) = 1 End If Next With Me.CmbDate .List = DicDate.keys .Text = .List(.ListCount - 1) End WithEnd Sub
代码解析：
（a）把明细表数据读入数组。
（b）给几个关键字段位置变量赋值，这样即便明细表字段顺序变化，也不影响取数，可以不用修改代码。
（c）把日期通过字典取得不重复值，赋值给组合框的list。
（3）日期组合框CmbDate_Change代码：
Private Sub CmbDate_Change() Dim dKey As String Dim DicType As Object Set DicTransaction = CreateObject("Scripting.Dictionary") Set DicType = CreateObject("Scripting.Dictionary") AllBonds = 0 BankBonds = 0 If Me.CmbDate = "" Then Exit Sub For i = 2 To iRow If CDate(arrDetail(i, DatePos)) <= CDate(Me.CmbDate) Then AllBonds = AllBonds + arrDetail(i, BalancePos) If BondType(arrDetail(i, TypePos)) = "政金债" Then BankBonds = BankBonds + arrDetail(i, BalancePos) End If End If If CDate(Me.CmbDate) = CDate(arrDetail(i, DatePos)) Then dKey = arrDetail(i, DatePos) & "|" & BondType(arrDetail(i, TypePos)) & "|" & arrDetail(i, DirectionPos) DicTransaction(dKey) = DicTransaction(dKey) + arrDetail(i, BalancePos) DicType(BondType(arrDetail(i, TypePos))) = 1 End If Next With Me.CmbBondType .Clear .List = DicType.keys .Text = .List(.ListCount - 1) End With If AllBonds = 0 Then BankBondsRate = "0.00%" Else BankBondsRate = Format(BankBonds / AllBonds, "0.00%") End IfEnd Sub
代码解析：
（a）日期变化，相应的债券总余额、政金债余额需要重算。
（b）日期变化，相应的债券类型也会变化。
（c）通过字典，取得债券类型赋值给组合框CmbBondType的list。
（d）计算政金债的占比。
（4）数据查询及格式设置代码：
Private Sub DataQuery() Dim arrtrans() Dim arrTem() Dim Tx_A1 As String Dim Tx_B2 As String Dim Tx_Bx As String Dim refRow As Integer Dim currBalance As Double Dim currAmount As Double Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("模板") ws.Activate Tx_A1 = Me.CmbBondType & "业务审批表(" & Me.CmbTradeDirection & ")" For i = 1 To iRow If ws.Cells(i, 2).Value = "二、持仓情况" Then refRow = i - 1 Exit For End If Next ws.Range(Cells(5, 2), Cells(refRow - 1, 9)).ClearContents If refRow > 8 Then For i = refRow - 1 To 8 Step -1 ws.Rows(i).Delete refRow = refRow - 1 Next End If k = 5 For i = 2 To iRow If CDate(arrDetail(i, DatePos)) = CDate(Me.CmbDate) Then If BondType(arrDetail(i, TypePos)) = Me.CmbBondType Then If arrDetail(i, DirectionPos) = Me.CmbTradeDirection Then For j = 2 To 9 ws.Cells(k, j) = arrDetail(i, pxy(ws.Cells(4, j), arrDetail, "Col", 1)) Next currBalance = currBalance + arrDetail(i, BalancePos) currAmount = currAmount + arrDetail(i, AmountPos) If refRow - k = 0 Then ws.Rows(5).Copy ws.Rows(k + 1).Insert ws.Rows(k + 1).ClearContents refRow = refRow + 1 End If k = k + 1 End If End If End If Next Tx_B2 = "拟在二级市场" & Me.CmbTradeDirection & Me.CmbBondType & currAmount & "万元" Tx_Bx = " 截止目前，已持仓债券余额" & AllBonds & "万元，其中：政策银行债余额" & BankBonds & "万元，占持仓债券总额的" & BankBondsRate & "。" With ws .Range("A1") = Tx_A1 .Range("A1").Font.Color = vbBlack .Range("A1").Characters(1, 3).Font.Color = vbRed .Range("A1").Characters(InStr(Tx_A1, "(") + 1, 2).Font.Color = vbRed .Range("b2") = Tx_B2 .Range("b2").Characters(InStr(Tx_B2, Me.CmbBondType), 3).Font.Color = vbRed .Range("b2").Characters(InStr(Tx_B2, Me.CmbBondType) + 3, Len(CStr(currAmount))).Font.Color = RGB(0, 238, 238) .Cells(refRow + 2, 2) = Tx_Bx .Cells(refRow + 2, 2).Characters(InStr(Tx_Bx, "持仓债券余额") + 6, Len(CStr(AllBonds))).Font.Color = RGB(0, 238, 238) .Cells(refRow + 2, 2).Characters(InStr(Tx_Bx, "政策银行债余额") + 7, Len(CStr(BankBonds))).Font.Color = RGB(0, 238, 238) .Cells(refRow + 2, 2).Characters(InStr(Tx_Bx, "债券总额的") + 5, Len(CStr(BankBondsRate))).Font.Color = RGB(0, 238, 238) .Cells(refRow + 6, 2) = Format(Me.CmbDate, "YYYY年MM月DD日") End With End Sub
代码解析：
（a）根据需求，组合成各种字符串。
（b）根据"二、持仓情况"字段所在单元格位置，计算一个参照行refRow。如果rerRow大于8，则表明上次打印行数超过了预设数，把它恢复。
（c）根据关键字筛选数据写入“模板”，如果明细数据行数超过预设行数，则相应插入行。
（d）把生成的字符串写入对应的单元格，并把关键字标色。这个并没有明确需求，但我看到模板里是这样标色的，随便也做了吧。
（5）债券类型CmbBondType_Change代码
Private Sub CmbBondType_Change() Dim DicDirection As Object If Me.CmbBondType = "" Then Exit Sub Set DicDirection = CreateObject("Scripting.Dictionary") For i = 2 To iRow If CDate(Me.CmbDate) = CDate(arrDetail(i, DatePos)) Then If BondType(arrDetail(i, TypePos)) = Me.CmbBondType Then DicDirection(arrDetail(i, DirectionPos)) = 1 End If End If Next With Me.CmbTradeDirection .Clear .List = DicDirection.keys .Text = .List(.ListCount - 1) End WithEnd Sub
代码解析：
（a）债券类型改变，相应的买卖方向也会发生变化，重新取数，以准确匹配。
（6）其他代码，包括两个自定义函数：
Private Sub CmdExist_Click() Unload MeEnd SubPrivate Sub CmdDataQuery_Click() Call DataQuery Unload MeEnd SubPrivate Sub CmdPrint_Click() Dim ws As Worksheet Call DataQuery If Application.Dialogs(xlDialogPrinterSetup).Show = False Then Exit Sub End If Set ws = ThisWorkbook.Sheets("模板") ws.PrintOut Copies:=1 Set ws = NothingEnd SubFunction pxy(tx, arr As Variant, Optional direction As String = "Col", Optional line As Integer = 1) On Error Resume Next iRow = UBound(arr, 1) iCol = UBound(arr, 2) If direction = "Col" Then For i = LBound(arr, 2) To iCol If arr(line, i) = tx Then pxy = i Exit Function End If Next Else For i = LBound(arr, 1) To iRow If arr(i, line) = tx Then pxy = i Exit Function End If Next End If pxy = 0End FunctionFunction BondType(sType) Dim cType As String cType = "/" & sType & "/" If InStr("/国开债/进出口债/农发债/", cType) > 0 Then BondType = "政金债" Else BondType = "其他债" End IfEnd Function
总结
1、问题初步解决，但不一定能完全满足需求，或者尚存有BUG，后续可能会有修改。
2、如果大家有什么特别需求，或者发现有BUG的，欢迎在评论留言，谢谢！
喜欢就点个赞、点在看、留个言呗！