凭证录入模板-检查核算项目&研发项目是否录入-CSDN博客

本文链接：https://blog.csdn.net/sx01117/article/details/128392236

Sub 凭证()
'-----*【凭证录入表格】变量*-----
Dim arr, i, hang, mrr
Dim kemudm, lie_kemudm, lie_hsxm, lie_yfxm

'-----*【科目表格】变量*-----
Dim brr, p
Dim lie_xiangmuhesuan
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")

'-----*进入【科目表格】获取核算项目*-----
Workbooks.Open "D:\学习资料\科目-匹配.xls"
brr = Range("A1").CurrentRegion
lie_xiangmuhesuan = Range("1:1").Find("项目辅助核算").Column
For p = 2 To UBound(brr)
    dic(brr(p, 1)) = brr(p, lie_xiangmuhesuan)
Next p
Workbooks("科目-匹配").Save
Workbooks("科目-匹配").Close
 
'-----*进入【凭证录入表格】检查核算项目是否录入*-----
hang = Range("F2").End(xlDown).Row
lie_kemudm = Range("1:1").Find("科目代码").Column
arr = Range("A1:O" & hang)
mrr = Range("L1:O" & hang)
lie_hsxm = Range("1:1").Find("核算项目").Column
lie_yfxm = Range("1:1").Find("研发项目").Column
For i = 2 To UBound(arr, 1)
    kemudm = arr(i, lie_kemudm)
    '如果该科目代码有项目辅助核算并且没有填写核算项目，则标识出来。
    If (dic(kemudm) = "部门" Or dic(kemudm) = "部门/研发项目") And arr(i, lie_hsxm) = "" Then
        mrr(i, 3) = "未录入核算项目"
    End If
    If dic(kemudm) = "部门/研发项目" And arr(i, lie_yfxm) = "" Then
        mrr(i, 4) = "未录入研发项目"
    End If
Next i
Range("L1:O" & hang) = mrr
 
End Sub