「开源系列」VBA：多类型、多文件联合转换工具

'********************************************************

'*程序名称：关于个人发票的财务系统数据转换工具
'*版权作者：刘相涛
'*发布版本：Ver1.1
'*发布日期：2017-06-07
'********************************************************____________________________________________________________________
 Function Reimbursement(ReiDingFName As String, SDPBBankFName As String, BOCankFName As String)
 
     '源数据工作薄工作表数量
     Dim cnt As Integer, thisworkbook As Workbook, thisworksheet As Worksheet
    '审批编号，审批状态，审批结果
     Dim SHPNO As String, SHPNONext As String, SHPStatus As String, SHPStatusNext As String, SHPResult As String, SHPResultNext As String, SHQType As String
    '收款人名称，收款人编码，收款金额,
    Dim SHKName As String, SHKCode As String, Money As Long
    '计数工具
    Dim i As Integer, j As Integer, k As Integer, p As Integer, n As Long
    Dim tempSumMoney As Double
    Dim ReportSum As Integer
    '钉钉导出的总记录数
    Dim SumRange As Integer
    Set thisworkbook = Workbooks(BOCankFName)
    '中国银行导出数据校验
    If Trim(thisworkbook.Worksheets(1).Cells(2, 1).Value) <> "查询账号[ Inquirer account number ]" _
        Or Trim(thisworkbook.Worksheets(1).Cells(2, 2).Value) <> "310360686712" _
        Or Trim(thisworkbook.Worksheets(1).Cells(4, 1).Value) <> "借方发生总笔数[ Total Numbers of Debited Payments ]" _
        Or Trim(thisworkbook.Worksheets(1).Cells(6, 1).Value) <> "贷方发生总笔数[ Total Numbers of Credited Payments ]" _
        Or Trim(thisworkbook.Worksheets(1).Cells(9, 1).Value) <> "交易类型[ Transaction Type ]" Then
        '不符合要求是提示并终止程序执行
        MsgBox ("中国银行明细数据不符合要求，请检查！")
        thisworkbook.Close
        On Error Resume Next
        Workbooks(BOCankFName).Close
        Exit Function
    End If
    Set thisworkbook = Workbooks(SDPBBankFName)
    '浦发银行导出数据校验
     If Trim(thisworkbook.Worksheets(1).Cells(1, 2).Value) <> "75010154800006628" _
        Or Trim(thisworkbook.Worksheets(1).Cells(2, 2).Value) <> "网金保险销售服务有限公司" _
        Or Trim(thisworkbook.Worksheets(1).Cells(4, 5).Value) <> "贷方金额" _
        Or Trim(thisworkbook.Worksheets(1).Cells(4, 7).Value) <> "对方账号" Then
        '不符合要求是提示并终止程序执行
        MsgBox ("浦发银行明细数据不符合要求，请检查！")
        thisworkbook.Close
        On Error Resume Next
        Workbooks(SDPBBankFName).Close
        Exit Function
    End If
    Set thisworkbook = Workbooks(ReiDingFName)
   '源数据模版校验
    If Trim(thisworkbook.Worksheets(1).Cells(1, 1).Value) <> "审批编号" _
      Or Trim(thisworkbook.Worksheets(1).Cells(1, 3).Value) <> "审批状态" _
      Or Trim(thisworkbook.Worksheets(1).Cells(1, 4).Value) <> "审批结果" _
      Or Trim(thisworkbook.Worksheets(1).Cells(1, 15).Value) <> "申请单" _
      Or Trim(thisworkbook.Worksheets(1).Cells(1, 16).Value) <> "事项说明" _
      Or Trim(thisworkbook.Worksheets(1).Cells(1, 18).Value) <> "金额（元）" Then   '2017-05-15半角空格调整为全角空格
        '不符合要求是提示并终止程序执行
        MsgBox ("报销数据不符合要求，请检查！")
        thisworkbook.Close
        On Error Resume Next
        Workbooks(ReiDingFName).Close
        Exit Function
    Else
        cnt = thisworkbook.Worksheets.Count
    End If
'----------------------------------------------------------------------------------------------------------------------
    '目标数据计数器
    ReimNewRange = 3
    k = 1
    Do While k <= cnt
        Set thisworksheet = thisworkbook.Sheets(k)
        '统计源数据记录数(含header)
        i = 1
        '待遍历数据源起始行
        j = 2
        SumRange = 1
        '统计源数据行数
        Do While thisworksheet.Cells(i, 1).Value <> ""
            i = i + 1
        Loop
        '去header
        SumRange = i - 1
        If SumRange = 1 Then
            MsgBox ("源数据含空数据页，请确认后删除！")
            Exit Function
        End If
        Dim Clown18Money As Double
        Dim Clown16SXSM As String
        Dim SHXFMoney As Double
        Dim Department As String
        Dim XiangmuLeixing As String
        Dim YusuanKemu As String
        Dim KJDate As String
        Dim WriteFlag As Boolean  '出力开关
        tempSumMoney = 0
        '编号重复行数
        ReportSum = 1
        Do
            '审批编号
            SHPNO = thisworksheet.Cells(j, 1).Value
            SHPNONext = thisworksheet.Cells(j + 1, 1).Value
            '审批状态
            SHPStatus = thisworksheet.Cells(j, 3).Value
            '审批结果
            SHPResult = thisworksheet.Cells(j, 4).Value
            '单据类型
            SHQType = thisworksheet.Cells(j, 15).Value
            '收款人名称
            SHKName = Replace(Replace(thisworksheet.Cells(j, 22).Value, Chr$(9), ""), Chr$(32), "")
            '收款人账号
            SHKCode = Replace(Replace(thisworksheet.Cells(j, 23).Value, Chr$(9), ""), Chr$(32), "")
            '阿里云会员充值特殊处理
            If SHKName = "阿里云会员账户" Or InStr(SHKName, "支付宝") = 1 Then
                SHKCode = "367558346053"
            End If
            '事项说明
            Clown16SXSM = thisworksheet.Cells(j, 16).Value
            '部门
            Department = thisworksheet.Cells(j, 19).Value
            '项目类型
            XiangmuLeixing = thisworksheet.Cells(j, 20).Value
            If XiangmuLeixing = "" Then
                XiangmuLeixing = "人民不会忘记"
            End If
            '预算科目
            YusuanKemu = thisworksheet.Cells(j, 21).Value
            '审批状态为"完成"且审批结果为"同意"
            If SHPStatus = "完成" And SHPResult = "同意" And SHQType <> "（冲）报销申请单" And SHKName <> "通联支付网络服务股份有限公司客户备付金" And _
            Clown16SXSM <> "代缴个税" And SHKCode <> "" Then
                If thisworksheet.Cells(j, 18).Value <> "" Then
                    Clown18Money = thisworksheet.Cells(j, 18).Value '金额（元）
                Else
                    Clown18Money = 0
                End If
                '同编号额度累计
                tempSumMoney = tempSumMoney + Clown18Money
                '部门代码
                Department = Left(Department, 5)
                '预算科目的代码
                YusuanKemu = Left(YusuanKemu, 6)
                '-----------------------------------------------------------------------------------------------------
                '当前记录与下一条记录比较,编号是否一致
                If SHPNO = SHPNONext And SHPNONext <> "" Then
                    WriteFlag = False
                    ReportSum = ReportSum + 1
                Else '如果编号不一致,则打开出力开关
                    WriteFlag = True
                End If
                If SHQType = "资金划拨单" And Clown16SXSM = "浦发6628收入户资金划转中行6712基本户" Then
                    Set thisworkbook = Workbooks(SDPBBankFName)
                    '统计银行数据行数
                    p = 5
                    '遍历从银行导出的数据文件
                    Do While thisworkbook.Worksheets(1).Cells(p, 1).Value <> ""
                        KJDate = ""
                        SHXFMoney = 0
                        '根据收款人账号和付款金额进行匹配
                        If thisworkbook.Worksheets(1).Cells(p, 4).Value <> "" Then
                            If thisworkbook.Worksheets(1).Cells(p, 7).Value = SHKCode And CDbl(Abs(thisworkbook.Worksheets(1).Cells(p, 4).Value)) = Clown18Money Then
                                '获取对应支付日期
                                KJDate = thisworkbook.Worksheets(1).Cells(p, 1).Value
                                If thisworkbook.Worksheets(1).Cells(p + 1, 7).Value = "" Then
                                    '获取税款
                                    SHXFMoney = Abs(thisworkbook.Worksheets(1).Cells(p + 1, 4).Value)
                                Else
                                     SHXFMoney = 0
                                End If
                                 Exit Do
                             End If
                        End If
                        p = p + 1
                    Loop
                   '申请单、借款的及部分划拨单，中国银行
                Else
                    Set thisworkbook = Workbooks(BOCankFName)
                    '统计银行数据行数
                    p = 10
                    '遍历从银行导出的数据文件
                    Do While thisworkbook.Worksheets(1).Cells(p, 1).Value <> ""
                        KJDate = ""
                        SHXFMoney = 0
                        '根据收款人账号和付款金额进行匹配
                        If thisworkbook.Worksheets(1).Cells(p, 9).Value = SHKCode And CDbl(Abs(thisworkbook.Worksheets(1).Cells(p, 14).Value)) = Clown18Money Then
                            '获取对应支付日期
                            KJDate = thisworkbook.Worksheets(1).Cells(p, 11).Value
                            If thisworkbook.Worksheets(1).Cells(p + 1, 2).Value = "收费" Then
                                '获取税款
                                 SHXFMoney = Abs(thisworkbook.Worksheets(1).Cells(p + 1, 14).Value)
                             Else
                                 SHXFMoney = 0
                             End If
                             Exit Do
                         End If
                         p = p + 1
                     Loop
                 End If
                '期间及日期
                Dim Dateperiod As String, LastDate As String
                '期间格式化
                Dateperiod = Left(KJDate, 4) & "-" & Mid(KJDate, 5, 2)
                '获取月份
                LastDate = Mid(KJDate, 5, 2)
                '日期格式转换
                KJDate = Datatransfer(KJDate, LastDate)
                '激活模版
                Workbooks("Oracel转换模版（保险公司）.xlsx").Activate
                '调用值写入函数
                Call WriteReimbursement(SHPNO, SHQType, SHKName, Clown16SXSM, Clown18Money, KJDate, Dateperiod, XiangmuLeixing, Department, YusuanKemu, SHXFMoney, WriteFlag, tempSumMoney, ReportSum)
                j = j + 1
            '审批状态或审批结果不符合要求
            Else
                j = j + 1
            End If
        Loop Until j > SumRange   '直至末行
        k = k + 1
       '激活源数据文件
        Set thisworkbook = Workbooks(ReiDingFName)
    Loop
    Application.DisplayAlerts = False
    '关闭源数据和银行数据文件
    Workbooks(BOCankFName).Close
    Workbooks(SDPBBankFName).Close
    Workbooks(ReiDingFName).Close
    Set thisworkbook = Workbooks("Oracel转换模版（保险公司）.xlsx")
    '定义目标数据文件路径及名称变量
    Dim FName As String
    '获取值
    FName = Application.GetSaveAsFilename(fileFilter:="Excel文件(*.xls),*.xls")
    '判断是否正常获取到预想值
    If FName = "False" Then
        MsgBox ("另存文件名为空，请确认！")
    Else
        '另存当前文件
        thisworkbook.SaveAs Filename:=FName
    End If
    '打开屏幕刷新
    'Application.ScreenUpdating = True
    '焦点定位到文件首
    Cells(1, 1).Select
    '完成提醒
    MsgBox ("Thanks for use")
End Function