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

泄密者 6 月 08, 2017 9 0

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

'*程序名称：关于个人发票的财务系统数据转换工具

'*版权作者：Tony Liu

'*发布版本：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

'不符合要求是提示并终止程序执行

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

'审批编号

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

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

'定义全局变量用于记录转换后的文件行标

Public ReimNewRange As Integer

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

'*将编辑好的数据写入到目标文件(个人发票)

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

Function WriteReimbursement(SHPNO As String, SHQType As String, SHKName As String, Clown16SXSM As String, Clown18Money As Double, KJDate As String, Dateperiod As String, XiangmuLeixing As String, _

Department As String, YusuanKemu As String, SHXFMoney As Double, WriteFlag As Boolean, tempSumMoney As Double, ReportSum As Integer)

'第一行金额

If Clown18Money <> 0 Then

Cells(ReimNewRange, 1).Value = "=InsuranceCompany!C2" '加载

Cells(ReimNewRange, 2).Value = "Ledger_WEBFIN" '分类账

Cells(ReimNewRange, 3).Value = "记账" '类别

Cells(ReimNewRange, 4).Value = "电子表格" '来源

Cells(ReimNewRange, 5).Value = "CNY" '币种

Cells(ReimNewRange, 6).Value = KJDate '会计结算日期

Cells(ReimNewRange, 7).Value = "000100" '公司

'————————————————成本中心—————————————————————

If SHQType = "借款申请单" Or SHQType = "资金划拨单" Then

Cells(ReimNewRange, 8).Value = "0"

Else

Cells(ReimNewRange, 8).Value = Department '成本中心

End If

'————————————————科目—————————————————————

If SHQType = "报销申请单" Then

Cells(ReimNewRange, 9).Value = "=iferror(vlookup(" & Chr$(34) & "*" & XiangmuLeixing & "*" & Chr$(34) & ",KEMU!D:E,2,false)," & Chr$(34) & "未找到" & Chr$(34) & ")" '科目

ElseIf SHQType = "划拨申请单" Then

If Clown16SXSM = "浦发6628收入户资金划转中行6712基本户" Then

Cells(ReimNewRange, 9).Value = "10020101"

Else

Cells(ReimNewRange, 9).Value = "39010101"

End If

'借款申请单

Else

If Clown16SXSM = "其他应收款-员工借款" Then

Cells(ReimNewRange, 9).Value = "12210701"

Else

Cells(ReimNewRange, 9).Value = "=iferror(vlookup(" & Chr$(34) & "*" & XiangmuLeixing & "*" & Chr$(34) & ",KEMU!D:E,2,false)," & Chr$(34) & "未找到" & Chr$(34) & ")" '科目

End If

'————————————————明细—————————————————————

If SHQType = "报销申请单" Then

Cells(ReimNewRange, 10).Value = YusuanKemu '明细

ElseIf SHQType = "划拨申请单" Then

If Clown16SXSM = "浦发6628收入户资金划转中行6712基本户" Then

Cells(ReimNewRange, 10).Value = "B010101"

Else

Cells(ReimNewRange, 10).Value = "=iferror(vlookup(" & Chr$(34) & "*" & SHKName & "*" & Chr$(34) & ",Company!A:B,2,false)," & Chr$(34) & "未找到" & Chr$(34) & ")" '明细

End If

'借款申请单

Else

If Clown16SXSM = "其他应收款-员工借款" Then

Cells(ReimNewRange, 10).Value = "=iferror(vlookup(" & Chr$(34) & "*" & SHKName & "*" & Chr$(34) & ",Person!A:B,2,false)," & Chr$(34) & "未找到" & Chr$(34) & ")" '明细

ElseIf InStr(Clown16SXSM, "其他应收款") = 1 Then

Cells(ReimNewRange, 10).Value = "=iferror(vlookup(" & Chr$(34) & "*" & SHKName & "*" & Chr$(34) & ",InsuranceCompany!A:B,2,false)," & Chr$(34) & "未找到" & Chr$(34) & ")" '明细

End If

'————————————————渠道————————————————————— '

'固定资产，渠道号为0，其它为0000

If InStr(XiangmuLeixing, "固定资产") <> 1 Then

Cells(ReimNewRange, 11).Value = "0000" '渠道

Else

Cells(ReimNewRange, 11).Value = "0" '渠道

End If

If SHQType = "划拨申请单" And Clown16SXSM = "浦发6628收入户资金划转中行6712基本户" Then

Cells(ReimNewRange, 11).Value = "XMZZ"

End If

Cells(ReimNewRange, 12).Value = "0" '产品

Cells(ReimNewRange, 13).Value = "0" '备用1

Cells(ReimNewRange, 14).Value = "0" '备用2

Cells(ReimNewRange, 15).Value = Clown18Money '在借款项

Cells(ReimNewRange, 16).Value = "" '贷项

Cells(ReimNewRange, 17).Value = Dateperiod '期间

Cells(ReimNewRange, 18).Value = SHPNO '批名

Cells(ReimNewRange, 19).Value = SHPNO '日记帐名称

Cells(ReimNewRange, 20).Value = Clown16SXSM '行说明

ReimNewRange = ReimNewRange + 1

End If

'第二行同编号合计

If WriteFlag = fale Then

Else

Cells(ReimNewRange, 1).Value = "=InsuranceCompany!C2" '加载

Cells(ReimNewRange, 2).Value = "Ledger_WEBFIN" '分类账

Cells(ReimNewRange, 3).Value = "记账" '类别

Cells(ReimNewRange, 4).Value = "电子表格" '来源

Cells(ReimNewRange, 5).Value = "CNY" '币种

Cells(ReimNewRange, 6).Value = KJDate '会计结算日期

Cells(ReimNewRange, 7).Value = "000100" '公司

Cells(ReimNewRange, 8).Value = "0" '成本中心

Cells(ReimNewRange, 9).Value = "10020101" '科目

'————————————————明细—————————————————————

If SHQType = "划拨申请单" And Clown16SXSM = "浦发6628收入户资金划转中行6712基本户" Then

Cells(ReimNewRange, 10).Value = "B090302"

Else

Cells(ReimNewRange, 10).Value = "B010101" '明细

End If

'————————————————渠道—————————————————————

'固定资产，渠道号为JYLC004，其它为TZLC001

If InStr(XiangmuLeixing, "固定资产") <> 1 Then

Cells(ReimNewRange, 11).Value = "TZLC001" '渠道

Else

Cells(ReimNewRange, 11).Value = "JYLC004" '渠道

End If

If SHQType = "划拨申请单" And Clown16SXSM = "浦发6628收入户资金划转中行6712基本户" Then

Cells(ReimNewRange, 11).Value = "XMZZ"

End If

Cells(ReimNewRange, 12).Value = "0" '产品

Cells(ReimNewRange, 13).Value = "0" '备用1

Cells(ReimNewRange, 14).Value = "0" '备用2

Cells(ReimNewRange, 15).Value = "" '借项

Cells(ReimNewRange, 16).Value = tempSumMoney '贷项

Cells(ReimNewRange, 17).Value = Dateperiod '期间

Cells(ReimNewRange, 18).Value = SHPNO '批名

Cells(ReimNewRange, 19).Value = SHPNO '日记帐名称

If ReportSum = 1 Then

Cells(ReimNewRange, 20).Value = Clown16SXSM '行说明

Else

Cells(ReimNewRange, 20).Value = "报销费用"

End If

ReimNewRange = ReimNewRange + 1

'第三行借项:手续费

If SHXFMoney <> 0 Then

Cells(ReimNewRange, 1).Value = "=InsuranceCompany!C2" '加载

Cells(ReimNewRange, 2).Value = "Ledger_WEBFIN" '分类账

Cells(ReimNewRange, 3).Value = "记账" '类别

Cells(ReimNewRange, 4).Value = "电子表格" '来源

Cells(ReimNewRange, 5).Value = "CNY" '币种

Cells(ReimNewRange, 6).Value = KJDate '会计结算日期

Cells(ReimNewRange, 7).Value = "000100" '公司

'————————————————成本中心—————————————————————

If SHQType = "划拨申请单" Then

If Clown16SXSM = "浦发6628收入户资金划转中行6712基本户" Then

Cells(ReimNewRange, 8).Value = "02001" '成本中心

Else

Cells(ReimNewRange, 8).Value = "00000" '成本中心

End If

Else

Cells(ReimNewRange, 8).Value = Department '成本中心

End If

Cells(ReimNewRange, 9).Value = "66030301" '科目.

Cells(ReimNewRange, 10).Value = "Y14016" '明细

Cells(ReimNewRange, 11).Value = "0000" '渠道

Cells(ReimNewRange, 12).Value = "0" '产品

Cells(ReimNewRange, 13).Value = "0" '备用1

Cells(ReimNewRange, 14).Value = "0" '备用2

Cells(ReimNewRange, 15).Value = SHXFMoney '借项

Cells(ReimNewRange, 16).Value = "" '贷项

Cells(ReimNewRange, 17).Value = Dateperiod '期间

Cells(ReimNewRange, 18).Value = SHPNO '批名

Cells(ReimNewRange, 19).Value = SHPNO '日记帐名称

If ReportSum = 1 Then

Cells(ReimNewRange, 20).Value = Clown16SXSM & "结算费" '行说明

Else

Cells(ReimNewRange, 20).Value = "报销费用结算费"

End If

ReimNewRange = ReimNewRange + 1

'第四行贷项：手续费

Cells(ReimNewRange, 1).Value = "=InsuranceCompany!C2" '加载

Cells(ReimNewRange, 2).Value = "Ledger_WEBFIN" '分类账

Cells(ReimNewRange, 3).Value = "记账" '类别

Cells(ReimNewRange, 4).Value = "电子表格" '来源

Cells(ReimNewRange, 5).Value = "CNY" '币种

Cells(ReimNewRange, 6).Value = KJDate '会计结算日期

Cells(ReimNewRange, 7).Value = "000100" '公司

Cells(ReimNewRange, 8).Value = "0" '成本中心

Cells(ReimNewRange, 9).Value = "10020101" '科目

If SHQType = "划拨申请单" And Clown16SXSM = "浦发6628收入户资金划转中行6712基本户" Then

Cells(ReimNewRange, 10).Value = "B090302"

Else

Cells(ReimNewRange, 10).Value = "B010101" '明细

End If

Cells(ReimNewRange, 11).Value = "JYLC004" '渠道

Cells(ReimNewRange, 12).Value = "0" '产品

Cells(ReimNewRange, 13).Value = "0" '备用1

Cells(ReimNewRange, 14).Value = "0" '备用2

Cells(ReimNewRange, 15).Value = "" '借项

Cells(ReimNewRange, 16).Value = SHXFMoney '贷项

Cells(ReimNewRange, 17).Value = Dateperiod '期间

Cells(ReimNewRange, 18).Value = SHPNO '批名

Cells(ReimNewRange, 19).Value = SHPNO '日记帐名称

If ReportSum = 1 Then

Cells(ReimNewRange, 20).Value = Clown16SXSM & "结算费" '行说明

Else

Cells(ReimNewRange, 20).Value = "报销费用结算费"

End If

ReimNewRange = ReimNewRange + 1

End If

tempSumMoney = 0

ReportSum = 1

End If

End Function

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

'日期格式转换

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

Function Datatransfer(KJDate As String, LastDate As String) As String

'Dim Datatransfer As String

'日期转换，分别针对31天、30天、28天的月份，如果支付日期为月末最后一天，则T+0，否则T+1

Select Case LastDate

'一三五七八十腊 31天

Case "01", "03", "05", "07", "08", "10", "12"

If Right(KJDate, 2) <> "31" Then

Datatransfer = Left(KJDate, 4) & "/" & Mid(KJDate, 5, 2) & "/" & CInt(Right(KJDate, 2)) + 1

Else

Datatransfer = Left(KJDate, 4) & "/" & Mid(KJDate, 5, 2) & "/" & CInt(Right(KJDate, 2))

End If

'四六九冬 30天

Case "04", "06", "09", "11"

If Right(KJDate, 2) <> "30" Then

Datatransfer = Left(KJDate, 4) & "/" & Mid(KJDate, 5, 2) & "/" & CInt(Right(KJDate, 2)) + 1

Else

Datatransfer = Left(KJDate, 4) & "/" & Mid(KJDate, 5, 2) & "/" & CInt(Right(KJDate, 2))

End If

'只有二月28天

Case "02"

If Right(KJDate, 2) <> "28" Then

Datatransfer = Left(KJDate, 4) & "/" & Mid(KJDate, 5, 2) & "/" & CInt(Right(KJDate, 2)) + 1

Else

Datatransfer = Left(KJDate, 4) & "/" & Mid(KJDate, 5, 2) & "/" & CInt(Right(KJDate, 2))

End If

Case Else

End Select

End Function

Via: itker.me

打赏赞

标签

相关推荐