fruncm server sql 无法生成 线程_ExcelVBA 通过明细生成报销单（同理可用于生成无限多期函证）...

昨天帮一从事务所转战企业的同事解决一个需求，其中原理其实也可用于制作无限多期函证。

❉源数据结构

基础数据截图如下：

案例见公众号共享文件夹“Excel-VBA”之“2、费用报销单.xlsm”：

https://share.weiyun.com/5xI2J0S

❉主要VBA知识点

1、字段(Dictionary)

本例用了“Add”和"Keys"。

2、简单的Sql语句

将Excel工作簿当做数据库，工作表当为数据库表，并利用ADODB.Connection打开数据库，利用ADODB.Recordset结合Sql语句读取记录。

ADODB.Connection：https://docs.microsoft.com/zh-cn/sql/ado/guide/appendixes/using-ado-with-microsoft-visual-basic?view=sql-server-ver15

ADODB.Recordset：https://docs.microsoft.com/zh-cn/sql/ado/reference/ado-api/recordset-object-ado?view=sql-server-ver15

本案例运用：

        Dim Cnn As Object 'ADODB.Connection

        Dim Rst As Object 'ADODB.Recordset

        Set Cnn = CreateObject("ADODB.Connection")

        Set Rst = CreateObject("ADODB.Recordset") 'New ADODB.Recordset

       Mysql = "Select 费用类别,摘要说明,报销金额,备注 from [目录$] where 单据序号='" & MyChildDic & "'"

        Rst.Open Mysql, Cnn, 1

3、定义名称

因明细中某报销单项目不定，相较模板存在增减行情形，且还需在生成的报销单中其他位置录入数据，为保证相对位置不变，方便后续在对应单元格写入数据，事先在“模板”中将对应单元格/区域定义为名称，是个很不错的选择。这种方法在附注工具中也充分运用了这一点。

本例中后续引用该名称时：

MyArray = Split(MyIndexDic(MyChildDic), "|")

.Range("ProjectID").Value = MyArray(0)

.Range("NotesDate").Value = MyArray(1)

.Range("NotesDepartment").Value = MyArray(2)

.Range("Person").Value = MyArray(3)

❉VBA代码

以下为“生成”按钮单击事件下的代码：

Private Sub CommandButton1_Click()

    Dim RowMax As Integer

    Dim i As Integer

    Dim MyIndexDic As Object 'New Dictionary

    Dim Cnn As Object 'ADODB.Connection

    Dim Rst As Object 'ADODB.Recordset

    Set Cnn = CreateObject("ADODB.Connection")

    Set Rst = CreateObject("ADODB.Recordset") 'New ADODB.Recordset

    Dim Mysql As String

    With Sheet1

        RowMax = .UsedRange.Rows.Count

        Set MyIndexDic = CreateObject("Scripting.Dictionary") 'New Dictionary

        For i = 2 To RowMax

            If .Cells(i, 1).Value = "√" And Len(.Cells(i, 2).Value) > 0 Then

                '将第一次遇见的项目号、日期、申请部门、申请人连接起来。

                MyIndexDic.Add .Cells(i, 2).Text, .Cells(i, 3) & "|" & .Cells(i, 4) & "|" & .Cells(i, 5) & "|" & .Cells(i, 6)

            End If

        Next

        If MyIndexDic.Count > 0 Then

            If MsgBox("共有张报销单要生成，确定要生成吗？" + vbCrLf + "当已存在同名报销单时，将会删除原同名报销单！", vbYesNo + vbQuestion, "提示！") = vbYes Then

                .Application.DisplayAlerts = False

                .Application.ScreenUpdating = False

                Dim MyChildDic As Variant

                Dim TempSheet As Worksheet

                Dim SheetNums As Integer

                Dim RercordCount As Integer

                Dim NotesDetailCount As Integer

                Dim MyArray

                Cnn.Open "Provider =Microsoft.ACE.OLEDB.12.0;Extended properties='Excel 12.0;HDR=YES;';data source=" & ThisWorkbook.FullName

                On Error Resume Next

                For Each MyChildDic In MyIndexDic.Keys

                    Err.Clear

                    Set TempSheet = ThisWorkbook.Worksheets(MyChildDic)

                    If Err.Number = 0 Then

                      TempSheet.Delete

                    End If

                    Err.Clear

                     SheetNums = ThisWorkbook.Sheets.Count

                     Mysql = "Select 费用类别,摘要说明,报销金额,备注 from [目录$] where 单据序号='" & MyChildDic & "'"

                     Rst.Open Mysql, Cnn, 1

                     Sheet2.Copy After:=Sheets(SheetNums)

                     Set TempSheet = ThisWorkbook.Worksheets(SheetNums + 1)

                     MyArray = Split(MyIndexDic(MyChildDic), "|")

                     With TempSheet

                         .Name = MyChildDic

                         .Range("ProjectID").Value = MyArray(0)

                         .Range("NotesDate").Value = MyArray(1)

                         .Range("NotesDepartment").Value = MyArray(2)

                         .Range("Person").Value = MyArray(3)

                         RercordCount = Rst.RecordCount

                         NotesDetailCount = .Range("NotesDetail").Rows.Count

                         If RercordCount > NotesDetailCount Then

                             For i = 1 To RercordCount - NotesDetailCount

                                .Range("NotesDetail").Rows(2).Select

                                Selection.Copy

                                Selection.Insert Shift:=xlDown

                             Next

                              Application.CutCopyMode = False

                          End If

                          Rst.MoveFirst

                          With .Range("NotesDetail")

                            i = 1

                            Do Until Rst.EOF

                                .Range("a" & i).Value = i

                                .Range("B" & i).Value = Rst.Fields("费用类别")

                                .Range("G" & i).Value = Rst.Fields("摘要说明")

                                .Range("N" & i).Value = Rst.Fields("报销金额")

                                .Range("P" & i).Value = Rst.Fields("备注")

                                i = i + 1

                                Rst.MoveNext

                            Loop

                         End With

                         .PageSetup.FitToPagesWide = 1

                         .PageSetup.FitToPagesTall = 1

                     End With

                     Rst.Close

                Next

                For i = 2 To RowMax '加超链接

                    If Len(.Cells(i, 2).Value) > 0 Then

                       .Range("B" & i).Hyperlinks.Delete

                        .Range("B" & i).Hyperlinks.Add Anchor:=.Range("B" & i), Address:="", SubAddress:=.Range("B" & i).Value & "!A1"

                    End If

                Next

                .Select

                .Application.DisplayAlerts = True

                 .Application.ScreenUpdating = True

                  MsgBox "费用报销单生成完毕！", vbOKOnly + vbInformation, "提示！"

            End If

         Else

             MsgBox "未勾选任何报销单，无法生成！", vbYesNo + vbQuestion, "提示！"

        End If

    End With

    Set MyIndexDic = Nothing

    Set Cnn = Nothing

    Set Rst = Nothing

    Set Cnn = Nothing

    Set Rst = Nothing

End Sub

使用方法：

1、填写目录表中自单据序号列至备注列信息；

2、生成列下勾选需生成的某张费用报销单，即可生成所勾选的费用报销单；

3、程序会自动在单据序号列中创建超链接，链接生成的报销单，并将报销单调整为1页宽1页高。