'********************************************************
'*程序名称：关于个人发票的财务系统数据转换工具
'*版权作者：刘相涛
'*发布版本：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
评论