检查凭证录入模板的核算项目

Sub 凭证()
Dim arr
Dim i, j, k, hang
Dim lie_debit, mrr
hang = Range("F2").End(xlDown).Row
arr = Range("A1:M" & hang)
mrr = Array("核算项目", "研发项目")
'填充空白单元格
For i = 2 To UBound(arr)
    For j = 1 To 3
        If arr(i, j) = "" Then
            arr(i, j) = arr(i - 1, j)
        End If
    Next j
Next i
Range("A1").Resize(UBound(arr), UBound(arr, 2)) = arr
Cells(1, 1).Select
Cells(2, 1).Select
Application.ActiveWindow.FreezePanes = True
Range("A1:M" & hang).AutoFilter
Range("I2:K" & hang).NumberFormatLocal = "#,##0.00_ "

lie_debit = Range("1:1").Find("贷方").Column
For k = 0 To UBound(mrr)
    Cells(1, lie_debit + k + 1).EntireColumn.Insert
    Cells(1, lie_debit + k + 1).Value = mrr(k)
    Cells(1, lie_debit + k + 1).EntireColumn.NumberFormatLocal = "@"
Next k

'进入部门表格获取部门编码
Workbooks.Open "D:\学习资料\部门-匹配.xls"
Dim brr, p
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
brr = Range("A1").CurrentRegion
For p = 2 To UBound(brr)
    dic(brr(p, 2)) = brr(p, 1)
Next p
Workbooks("部门-匹配").Save
Workbooks("部门-匹配").Close

'进入凭证录入表格匹配核算项目
'Workbooks("凭证模板 - 录入").Activate
Dim m, keyStr, zifushu
Dim lie_hsxm, lie_yfxm, hsxm, yfxm
Dim crr
keyStr = "/"
lie_hsxm = Range("1:1").Find(mrr(0)).Column
lie_yfxm = Range("1:1").Find(mrr(1)).Column
lie_kemu = Range("1:1").Find("科目名称").Column
ReDim crr(1 To UBound(arr), 1 To 2)
crr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(crr))
For m = 2 To UBound(arr, 1)
    zifushu = ziFuGeShu(arr(m, lie_kemu), keyStr)
    If zifushu >= 2 Then
        hsxm = tiQuZiFu(arr(m, lie_kemu), keyStr, 1)
        crr(m, 1) = dic(hsxm)
        yfxm = tiQuZiFu(arr(m, lie_kemu), keyStr, 2)
        crr(m, 2) = "05"
    ElseIf zifushu >= 1 Then
        hsxm = tiQuZiFu(arr(m, lie_kemu), keyStr, 1)
        crr(m, 1) = dic(hsxm)
    ElseIf zifushu = 0 Then
        crr(m, 1) = ""
        crr(m, 2) = ""
    End If
Next m

End Sub
Function tiQuZiFu(str, keyStr, ciShu)
Dim str_result, wz_1, wz_2
wz_1 = ziFuWeiZhi(str, keyStr, ciShu)
geShu = ziFuGeShu(str, keyStr)
If geShu >= 2 Then
    wz_2 = ziFuWeiZhi(str, keyStr, ciShu + 1)
End If
If geShu = 1 Then
    str_result = Mid(str, wz_1 + 1, 99)
Else
    If ciShu <> geShu Then
        str_result = Mid(str, wz_1 + 1, wz_2 - wz_1 - 1)
    Else
        str_result = Mid(str, wz_1 + 1, 99)
    End If
End If
tiQuZiFu = str_result
End Function

Function ziFuWeiZhi(str, keyStr, ciShu)
Dim geShu, wz_1, wz_result
geShu = ziFuGeShu(str, keyStr)
If geShu = 1 Then
    wz_result = InStr(1, str, keyStr, 1)
Else
    wz_1 = InStr(1, str, keyStr, 1)
    If ciShu = 1 Then
        wz_result = wz_1
    ElseIf ciShu = 2 Then
        wz_result = InStr(wz_1 + 1, str, keyStr, 1)
    Else
        wz_result = "weiZhi不是1和2"
    End If
End If
ziFuWeiZhi = wz_result
End Function

Function ziFuGeShu(str, keyStr)
Dim len_str, zifu
Dim i, gs_result
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")

len_str = Len(str)
For i = 1 To len_str
    zifu = Mid(str, i, 1)
    If zifu = keyStr Then
        If Not dic.exists(zifu) Then
            dic(keyStr) = ""
            gs_result = 1
        Else
            gs_result = gs_result + 1
        End If
    End If
Next i
ziFuGeShu = gs_result

End Function