财务发票智能拆分

Public dic_tax As Object
Public dic_jishu_row As Object
Public cnt_output
Public val_jishu
Sub 清空src()
    With Sheets("src")
        .Range("a2:m65535").ClearContents
    End With
End Sub
Sub 验证发票金额()
    int_split_before = 获取原始数据里的总金额
    int_split_after = 获取拆分后的总金额
    If int_split_before = int_split_after Then
        MsgBox int_split_before & "  本次拆分前后总金额相等  " & int_split_after
    Else
        MsgBox "拆分前后总金额不相等,请检查!"
    End If
End Sub
Function 获取拆分后的总金额()
    For Each sht In Sheets
        sht_name = sht.Name
        If IsNumeric(sht_name) Then
            With Sheets(sht_name)
                ar = .Range("a1").CurrentRegion
                For x = 2 To UBound(ar)
                    i = i + ar(x, 7)
                Next
            End With
        End If
    Next
    获取拆分后的总金额 = Int(i)
End Function
Function 获取原始数据里的总金额()
    With Sheets("res")
        lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        ar = .Range("a1:e" & lastrow)
        For x = 2 To UBound(ar)
            i = i + ar(x, 5) * 1
        Next
    End With
    '获取原始数据里的总金额 = Int(i * 1.09)
    获取原始数据里的总金额 = Int(i)
End Function
Sub 从文件夹获取原始数据()
    getTiHuoMingXi
End Sub

Function getFilePathFromMeiYunXiaoSheet() '获取美云销[客户往来对账明细]路径
    ' MsgBox "请选择从美云销下载的[客户往来对账明细]表!"
    With Application.FileDialog(msoFileDialogFilePicker)
        '.InitialFileName = "C:\Users\Administrator\Desktop\管家婆\CCS_提货_入库_比对_codeCollection\提货_入库比对\"
        .InitialFileName = ThisWorkbook.path
        .AllowMultiSelect = False
        If .Show Then p = .SelectedItems(1) Else: Exit Function
    End With
    getFilePathFromMeiYunXiaoSheet = p
End Function
Private Sub getTiHuoMingXi() '获取提货明细
    'MsgBox "请选择从美云销下载的[客户往来对账明细]表!"
    Dim cnn As New ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim SQL As String
    Dim i As Integer
    Dim myPath As String
    On Error GoTo ErrMsg
    'myPath = "C:\Users\Administrator\Desktop\管家婆\CCS_提货_入库_比对_codeCollection\提货_入库比对\CCS0516\提货明细\"
    'cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & myPath & "提货明细04.xlsx"
    cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & getFilePathFromMeiYunXiaoSheet & ""
    SQL = "select * from [Sheet1$C5:N] where 物料名称 is not null"
    Set rst = cnn.Execute(SQL)
    With Sheets("src")
        .Range("a2:m65535").ClearContents
        'For i = 0 To rst.Fields.Count - 1
        '.Cells(1, i + 1) = rst.Fields(i).Name
        'Next
        .Range("a2").CopyFromRecordset rst
    End With
    
    rst.Close
    cnn.Close
    Set rst = Nothing
    Set cnn = Nothing
    Exit Sub
ErrMsg:
    MsgBox Err.Description, , "错误报告"
End Sub
Private Sub 合计金额验证()
    With Sheets("src")
        ar = .Range("a1").CurrentRegion
        For x = 2 To UBound(ar)
            k = k + ar(x, 10)
        Next
        res = k * 1.09
    End With
    With Sheets("res")
        .[q2] = res
        .[p2] = k
    End With
End Sub
Sub 获取全部产品()                                               '分类汇总 水果+蔬菜一起
    Application.ScreenUpdating = False
    '    Dim o As New cClassSqlHelperForTableDB
    If 原始数据区分水果和蔬菜 = True And 检查tax表格分类是否完整 = True Then
        SQL = "select null as 序号,物料名称,sum(实收数量) as 数量,round(无税单价*1.09,5) as 含税单价" _
            & ",round(sum(无税金额)*1.09,2) as 含税金额 from [src$] where 物料名称 is not  null group by 物料名称,无税单价 order by 物料名称"
        Call ExecteFilterOverRideThree(SQL, 2, 1, 1, 1, "res")
        Call addNumber
    Else
        MsgBox "存在物料未分类！"
        End
    End If
    Application.ScreenUpdating = True
End Sub
'Sub getSrcDataForFruit() '分类汇总 水果
'Dim o As New cClassSqlHelperForTableDB
''sql_fruit = "select 物料名称 from [fru$]"
'sql_fruit = "select 物料名称 from [tax$] where 税类码='水果'"
'sql = "select null as 序号,物料名称,sum(实收数量) as 数量,round(无税单价*1.09,5) as 含税单价" _
    '& ",round(sum(无税金额)*1.09,2) as 含税金额 from [src$] where 物料名称 is not  null and 物料名称 in(" & sql_fruit & ") group by 物料名称,无税单价 order by 物料名称"
'Call o.ExecteFilterOverRideThree(sql, 2, 1, 1, 1, "res")
'Call addNumber
'End Sub
'Sub getSrcDataForVagetable() '分类汇总 蔬菜
'Dim o As New cClassSqlHelperForTableDB
''sql_vegetable = "select 物料名称 from [veg$]"
'sql_vegetable = "select 物料名称 from [tax$] where 税类码='蔬菜'"
'sql = "select null as 序号,物料名称,sum(实收数量) as 数量,round(无税单价*1.09,5) as 含税单价" _
    '& ",round(sum(无税金额)*1.09,2) as 含税金额 from [src$] where 物料名称 is not  null and 物料名称 in(" & sql_vegetable & ") group by 物料名称,无税单价 order by 物料名称"
'Call o.ExecteFilterOverRideThree(sql, 2, 1, 1, 1, "res")
'Call addNumber
'End Sub
Private Sub getSrcDataForFruit()                           '分类汇总 水果
    Application.ScreenUpdating = False
    Dim o As New cClassSqlHelperForTableDB
    If 原始数据区分水果和蔬菜 = True And 检查tax表格分类是否完整 = True Then
        SQL = "select null as 序号,物料名称,sum(实收数量) as 数量,round(无税单价*1.09,5) as 含税单价" _
            & ",round(sum(无税金额)*1.09,2) as 含税金额 from [src$] where 分类='水果' group by 物料名称,无税单价 order by 物料名称"
        Call o.ExecteFilterOverRideThree(SQL, 2, 1, 1, 1, "res")
        Call addNumber
        Call 水果金额求和验证
        Call 合计金额验证
    Else
        MsgBox "存在物料未分类！"
        End
    End If
    Application.ScreenUpdating = True
End Sub
Sub getSrcDataForFruitOverride()                           '分类汇总 水果
    Application.ScreenUpdating = False
    '    Dim o As New cClassSqlHelperForTableDB
    If 原始数据区分水果和蔬菜 = True And 检查tax表格分类是否完整 = True Then
        '    sql = "select null as 序号,物料名称,sum(实收数量) as 数量,round(无税单价*1.09,5) as 含税单价" _
            '    & ",round(sum(无税金额)*1.09,2) as 含税金额 from [src$] where 分类='水果' group by 物料名称,无税单价"
        SQL = "select null as 序号,物料名称,sum(实收数量) as 数量, round((sum(无税单价)/count(*))*1.09,5) as 含税单价," _
            & "round((sum(实收数量)*round((sum(无税单价)/count(*))*1.09,5)),2) as 含税金额 from [src$] where 分类='水果' group by 物料名称"
        Call ExecteFilterOverRideThree(SQL, 2, 1, 1, 1, "res")
        Call addNumber
        Call 水果金额求和验证
        Call 合计金额验证
    Else
        MsgBox "存在物料未分类！"
        End
    End If
    Application.ScreenUpdating = True
End Sub
Private Sub 水果金额求和验证()
    With Sheets("res")
        lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For x = 2 To lastrow
            k = k + .Cells(x, 5)
        Next
        .[r2] = k
    End With
End Sub
Sub 加工品发票入口()                                              '分类汇总 加工品 13%税率  2022 02 07
    Application.ScreenUpdating = False
    '    Dim o As New cClassSqlHelperForTableDB
    If 原始数据区分水果和蔬菜 = True And 检查tax表格分类是否完整 = True Then
        SQL = "select null as 序号,物料名称,sum(实收数量) as 数量, round((sum(无税单价)/count(*))*1.13,5) as 含税单价," _
            & "round((sum(实收数量)*round((sum(无税单价)/count(*))*1.13,5)),2) as 含税金额 from [src$] where 分类='加工品' group by 物料名称"
        Call ExecteFilterOverRideThree(SQL, 2, 1, 1, 1, "res")
        Call addNumber
        Call 蔬菜金额求和验证
    Else
        MsgBox "存在物料未分类！"
        End
    End If
    Application.ScreenUpdating = True
End Sub
Sub 肉类水产发票入口()                                             '分类汇总 加工品 9%税率  2022 02 07
    Application.ScreenUpdating = False
    '    Dim o As New cClassSqlHelperForTableDB
    If 原始数据区分水果和蔬菜 = True And 检查tax表格分类是否完整 = True Then
        SQL = "select null as 序号,物料名称,sum(实收数量) as 数量, round((sum(无税单价)/count(*))*1.09,5) as 含税单价," _
            & "round((sum(实收数量)*round((sum(无税单价)/count(*))*1.09,5)),2) as 含税金额 from [src$] where 分类='肉类' or 分类='水产' group by 物料名称"
        Call ExecteFilterOverRideThree(SQL, 2, 1, 1, 1, "res")
        Call addNumber
        Call 蔬菜金额求和验证
    Else
        MsgBox "存在物料未分类！"
        End
    End If
    Application.ScreenUpdating = True
End Sub
Sub getSrcDataForVagetableOverride()                       '分类汇总 蔬菜
    Application.ScreenUpdating = False
    '    Dim o As New cClassSqlHelperForTableDB
    If 原始数据区分水果和蔬菜 = True And 检查tax表格分类是否完整 = True Then
        SQL = "select null as 序号,物料名称,sum(实收数量) as 数量, round((sum(无税单价)/count(*))*1.09,5) as 含税单价," _
            & "round((sum(实收数量)*round((sum(无税单价)/count(*))*1.09,5)),2) as 含税金额 from [src$] where 分类='蔬菜' group by 物料名称"
        Call ExecteFilterOverRideThree(SQL, 2, 1, 1, 1, "res")
        Call addNumber
        Call 蔬菜金额求和验证
    Else
        MsgBox "存在物料未分类！"
        End
    End If
    Application.ScreenUpdating = True
End Sub
Private Sub getSrcDataForVagetable()                       '分类汇总 蔬菜
    Application.ScreenUpdating = False
    Dim o As New cClassSqlHelperForTableDB
    If 原始数据区分水果和蔬菜 = True And 检查tax表格分类是否完整 = True Then
        SQL = "select null as 序号,物料名称,sum(实收数量) as 数量,round(无税单价*1.09,5) as 含税单价" _
            & ",round(sum(无税金额)*1.09,2) as 含税金额 from [src$] where 分类='蔬菜' group by 物料名称,无税单价 order by 物料名称"
        Call o.ExecteFilterOverRideThree(SQL, 2, 1, 1, 1, "res")
        Call addNumber
        Call 蔬菜金额求和验证
    Else
        MsgBox "存在物料未分类！"
        End
    End If
    Application.ScreenUpdating = True
End Sub
Private Sub 蔬菜金额求和验证()
    With Sheets("res")
        lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For x = 2 To lastrow
            k = k + .Cells(x, 5)
        Next
        .[s2] = k
    End With
End Sub
Private Sub addNumber()                                    '添加序号
    With Sheets("res")
        .[a1] = "序号"
        lastrow = .Cells(.Rows.Count, 2).End(xlUp).Row
        For x = 2 To lastrow
            k = k + 1
            .Cells(x, 1) = k
        Next
    End With
End Sub
Sub main() '发票拆分
    Application.ScreenUpdating = False
    Call 从src读取单位到count
    Call 奇数行字典
    Call addTable
    Call splitByJinE
    'Call getTaxIDX '获取税类码
    Call addCalDanWei
    'Call formatted
    Call 处理奇数行
    Call getTaxIDX                                             '获取税类码
    'Call 分类汇总.循环分类汇总
    Call formatted
    Call 单位2
    Call 拆分为工作簿
    MsgBox "拆分完成后请将xlsx格式转为xls"
    Application.ScreenUpdating = True
End Sub
Sub 从src读取单位到count()
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("count")
        ar = .Range("a1").CurrentRegion
        For x = 2 To UBound(ar)
            dic(ar(x, 1)) = ar(x, 2)
        Next
    End With
    
    Set dic_not = CreateObject("scripting.dictionary")
    With Sheets("src")
        br = .Range("a1").CurrentRegion
        For y = 2 To UBound(br)
            If Not dic.exists(br(y, 6)) Then
                dic_not(br(y, 6)) = br(y, 7)
            End If
        Next
    End With
    arKey = dic_not.keys
    
    With Sheets("count")
        lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        
        If dic_not.Count > 0 Then
            .Cells(lastrow, 1).Resize(dic_not.Count, 1) = Application.Transpose(dic_not.keys)
            .Cells(lastrow, 2).Resize(dic_not.Count, 1) = Application.Transpose(dic_not.items)
        End If
    End With
End Sub
Private Sub 处理奇数行()
    With Sheets("res")
        lastrow = .Cells(.Rows.Count, 2).End(xlUp).Row
        ar = .Range("b1:e" & lastrow)
    End With
    If dic_jishu_row.Count > 0 Then
        tem = dic_jishu_row.keys
        val_jishu = ar(tem(0), 4)
        Call writeSheetsByRow(ar, tem(0), cnt_output)
    End If
End Sub
'Sub formatted() '格式化
' For Each sht In Sheets
'           sht_name = sht.Name
'           If IsNumeric(sht_name) Then
'            With Sheets(sht_name)
'                .Cells.EntireColumn.AutoFit
'                .Range("a1").CurrentRegion.Sort key1:=.Range("b1"), order1:=xlAscending, Header:=xlYes '升序
'                .Columns("f:f").NumberFormatLocal = "0.00000"
'            End With
'           End If
'Next sht
'End Sub
Private Sub formatted()                                    '格式化
    For Each sht In Sheets
        sht_name = sht.Name
        '           If IsNumeric(sht_name) Then
        If InStr(sht_name, "fin") > 0 Or IsNumeric(sht_name) Then
            With Sheets(sht_name)
                .Select
                r = .Cells(.Rows.Count, 1).End(xlUp).Row
                .Cells.EntireColumn.AutoFit
                .Rows(1).RowHeight = 54
                .Range("a1:k1").Interior.ColorIndex = 40
                .Range("a1").CurrentRegion.Sort key1:=.Range("b1"), order1:=xlAscending, Header:=xlYes    '升序
                .Columns("f:f").NumberFormatLocal = "0.00000"
                .Range(Cells(1, 1), Cells(r, 11)).Borders.LineStyle = 1
            End With
        End If
    Next sht
End Sub
Private Sub 奇数行字典()
    Set dic_jishu_row = CreateObject("scripting.dictionary")
    With Sheets("res")
        lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For x = 2 To lastrow
            dic_jishu_row(x) = ""
        Next
    End With
End Sub
Private Sub splitByJinE()
    Dim sum_contain_tax As Double                              '总含税金额
    Dim max_row_src_data As Long
    Call clearData
    cnt_output = 1
    With Sheets("res")
        lastrow = .Cells(.Rows.Count, 2).End(xlUp).Row
        ar = .Range("b1:e" & lastrow)
        max_row_src_data = UBound(ar)
        For i = 1 To 100                                       '随机10次打乱序列
            Call sortForSourceData(max_row_src_data)           '随机乱序排列
        Next
        '.Range("a1").CurrentRegion.Sort .[e1], xlAscending, Header:=xlYes
        ar = .Range("b1:e" & lastrow)
        k_start2last = 2
        max_row = UBound(ar)
        k_last2start = UBound(ar)
        vali_data = max_row / 2
        While k_start2last <= Application.WorksheetFunction.Ceiling(vali_data, 1)
            'row_sum = row_sum + 2
            valAsc = ar(k_start2last, 4)
            valdesc = ar(k_last2start, 4)
            tem_val = tem_val + valAsc + valdesc
            dic_jishu_row.Remove k_start2last
            dic_jishu_row.Remove k_last2start
            If tem_val < 105000 Then
                Call writeSheetsByRow(ar, k_start2last, cnt_output)
                Call writeSheetsByRow(ar, k_last2start, cnt_output)
            End If
            k_start2last = k_start2last + 1
            k_last2start = k_last2start - 1
            sum_ = sum_ + valAsc + valdesc
            If sum_ < 105000 And sum_ > 100000 Then
                cnt_output = cnt_output + 1
                sum_ = 0
                'row_sum = 0
                tem_val = 0
            End If
            '    sum_contain_tax = sum_contain_tax + valAsc + valdesc
            sum_contain_tax = sum_contain_tax + valAsc + valdesc + val_jishu
            'val_jishu
        Wend
    End With
    'MsgBox "发票拆分完成,发票总金额为:" & Round(sum_contain_tax, 2)
End Sub
Private Sub writeSheetsByRow(arr, r, sheet_index)
    With Sheets(Format(sheet_index, "00"))
        .Select
        lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lastrow = lastrow + 1
        '.Cells(lastRow, 1).Resize(1, 4) = Application.Index(arr, r, 0)
        '.Cells(lastRow, 5) = r
        tem_arr = Application.Index(arr, r, 0)
        Call outputArrByCol(tem_arr, sheet_index)
    End With
End Sub
'
Private Sub outputArrByCol(ar, shtIndex)
    If ar(2) > 0 Then
        With Sheets(Format(shtIndex, "00"))
            lastrow = .Cells(.Rows.Count, 2).End(xlUp).Row
            lastrow = lastrow + 1
            .Cells(lastrow, 2) = ar(1)                         '商品名称
            .Cells(lastrow, 5) = ar(2)                         '数量
            .Cells(lastrow, 6) = Round(ar(3), 5)               '含税单价
            .Cells(lastrow, 8) = 0.09                          '税率
            '=RC[-2]*RC[-1]
            .Cells(lastrow, 7) = "=ROUND(RC[-2]*RC[-1],2)"     '含税金额
            '.Cells(lastRow, 7) = ar(4)
            '.Cells(lastRow, 8) = "=ROUND(RC[-1]/(1+RC[-2])*RC[-2],2)" '税额
        End With
    End If
End Sub
Private Sub clearData()
    For Each sht In Sheets
        If InStr(sht.Name, "res") = 0 And InStr(sht.Name, "src") = 0 And InStr(sht.Name, "tax") = 0 And InStr(sht.Name, "count") = 0 Then
            With Sheets(sht.Name)
                .Range("a2:e65535").ClearContents
            End With
        End If
    Next sht
End Sub
Private Sub sortForSourceData(maxRow As Long)              '提取随机不重复数字
    arr = GetRnd(1, maxRow, maxRow)
    Sheets("res").Range("a1") = "序号"
    Sheets("res").Range("a2").Resize(UBound(arr)) = Application.Transpose(arr)
    With Sheets("res")
        .Range("a1").CurrentRegion.Sort .[a1], xlAscending, Header:=xlYes
    End With
End Sub
Private Function GetRnd(a&, b&, n&)                        '数组洗牌法 提取不重复随机数
    Dim i&, m&, r&, t
    ReDim ar&(a To b), br(n - 1)
    For i = a To b
        ar(i) = i
    Next
    m = b - a + 1
    Randomize
    For i = 0 To n - 1
        r = Int(Rnd * (m - i)) + i + a
        t = ar(r): ar(r) = ar(i + a): ar(i + a) = t: br(i) = t
    Next
    GetRnd = br
End Function
Private Sub proName2Tax()
    Set dic_type2tax = CreateObject("scripting.dictionary")
    Set dic_tax = CreateObject("scripting.dictionary")
    With Sheets("tax")
        dic_type2tax.Add .[s2].Value, .[r2].Value
        dic_type2tax.Add .[s3].Value, .[r3].Value
        dic_type2tax.Add .[s4].Value, .[r4].Value
        dic_type2tax.Add .[s5].Value, .[r5].Value
        dic_type2tax.Add .[s6].Value, .[r6].Value
        arItem1 = dic_type2tax.items
        ar = .Range("a1").CurrentRegion
        For x = 2 To UBound(ar)
            dic_tax(ar(x, 1)) = dic_type2tax(ar(x, 2))
        Next
    End With
    arItem = dic_tax.items
End Sub
Private Sub getTaxIDX()
    Call proName2Tax
    Application.DisplayAlerts = False
    For Each sht In Sheets
        If InStr(sht.Name, "res") = 0 And InStr(sht.Name, "src") = 0 And InStr(sht.Name, "tax") = 0 And InStr(sht.Name, "fru") = 0 And InStr(sht.Name, "veg") = 0 And InStr(sht.Name, "count") = 0 Then
            With Sheets(sht.Name)
                .Select
                .Columns("a:a").NumberFormatLocal = "@"
                lastrow = .Cells(.Rows.Count, 2).End(xlUp).Row
                For x = 2 To lastrow
                    .Cells(x, 1) = dic_tax(.Cells(x, 2).Value)
                Next
            End With
        End If
    Next sht
    Application.DisplayAlerts = True
End Sub
Private Sub deleteOldTable()
    Application.DisplayAlerts = False
    For Each sht In Sheets
        If InStr(sht.Name, "res") = 0 And InStr(sht.Name, "src") = 0 And InStr(sht.Name, "tax") = 0 And InStr(sht.Name, "fru") = 0 And InStr(sht.Name, "veg") = 0 And InStr(sht.Name, "count") = 0 Then
            sht.Delete
        End If
    Next sht
    Application.DisplayAlerts = True
End Sub
'={"税收分类编码","商品名称","规格型号","计量单位","数量","单价","金额","税率","优惠政策","免税类型","含税标志"}
Private Sub addTable()                                     '添加表格
    deleteOldTable
    num_talbe = getNeedAddTableCount + 1
    For i = 1 To num_talbe
        Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        With ws
            .Name = Format(i, "00")
            '.Range("a1").Resize(1, 8) = [{"商品名称","规格","单位","数量","含税单价","税率","含税金额","税额"}]
            .Range("a1").Resize(1, 11) = [{"税收分类编码","商品名称","规格型号","计量单位","数量","单价","金额","税率","优惠政策","免税类型","含税标志"}]
        End With
    Next
    '添加fin_res表格
    '        For i = 1 To num_talbe
    '        Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    '        With ws
    '        .Name = "fin" & Format(i, "00")
    '        '.Range("a1").Resize(1, 8) = [{"商品名称","规格","单位","数量","含税单价","税率","含税金额","税额"}]
    '        .Range("a1").Resize(1, 11) = [{"税收分类编码","商品名称","规格型号","计量单位","数量","单价","金额","税率","优惠政策","免税类型","含税标志"}]
    '        End With
    '        Next
End Sub
Private Function getNeedAddTableCount()                    '计算需要添加的表格数量
    Dim vTotalMoney As Double
    Dim invoiceNo  As Long
    With Sheets("res")
        r = .Cells(Rows.Count, 1).End(xlUp).Row
        For x = 2 To r
            vTotalMoney = vTotalMoney + .Cells(x, 5)
        Next
    End With
    If vTotalMoney = 0 Then Exit Function
    invoiceNo = Int(vTotalMoney / 105000) + 1
    getNeedAddTableCount = invoiceNo
End Function
Private Sub addCalDanWei()                                 '计量单位
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("src")
        ar = .Range("a1").CurrentRegion
        For x = 2 To UBound(ar)
            dic(ar(x, 6)) = ar(x, 7)
        Next
    End With
    arItem = dic.items
    For Each sht In Sheets
        If IsNumeric(sht.Name) Then
            With Sheets(sht.Name)
                lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
                For x = 2 To lastrow
                    s = .Cells(x, 2).Value
                    If dic.exists(s) Then
                        .Cells(x, 4) = dic(s)
                    End If
                Next
            End With
        End If
    Next sht
End Sub
Private Function 原始数据区分水果和蔬菜() As Boolean
    Set mapping = CreateObject("scripting.dictionary")
    Set dic_not_fl = CreateObject("scripting.dictionary")
    With Sheets("tax")
        ar = .Range("a1").CurrentRegion
        For x = 2 To UBound(ar)
            mapping(ar(x, 1)) = ar(x, 2)
        Next
    End With
    With Sheets("src")
        .[m1] = "分类"
        lastrow = .Cells(.Rows.Count, 6).End(xlUp).Row
        For x = 2 To lastrow
            s = .Cells(x, "f")
            If mapping.exists(s) Then
                .Cells(x, "m") = mapping(s)
            Else
                If Len(s) > 0 Then
                    dic_not_fl(s) = ""
                End If
            End If
        Next
    End With
    k = dic_not_fl.Count
    With Sheets("tax")
        lrow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        If k > 0 Then
            'MsgBox "存在物料未分类！"
            原始数据区分水果和蔬菜 = False
            .Cells(lrow, 1).Resize(dic_not_fl.Count) = Application.Transpose(dic_not_fl.keys)
        Else
            'MsgBox "当前物料已分类!"
            原始数据区分水果和蔬菜 = True
        End If
    End With
End Function
Private Function 检查tax表格分类是否完整() As Boolean
    With Sheets("tax")
        ar = .Range("a1").CurrentRegion
        For x = 2 To UBound(ar)
            If Len(ar(x, 2)) = 0 Then
                k = k + 1
            End If
        Next
    End With
    If k > 0 Then
        检查tax表格分类是否完整 = False
    Else
        检查tax表格分类是否完整 = True
    End If
End Function
Private Sub isFruitOrVegetable()
    Set dic_fru_or_veg = CreateObject("scripting.dictionary")
    '判断是水果还是蔬菜
    With Sheets("tax")
        ar = .Range("a1").CurrentRegion
        For x = 2 To UBound(ar)
            dic_fru_or_veg(ar(x, 1)) = ar(x, 2)
        Next
    End With
    With Sheets("res")
        .[f1] = "分类"
        lastrow = .Cells(.Rows.Count, 2).End(xlUp).Row
        For x = 2 To lastrow
            .Cells(x, "f") = dic_fru_or_veg(.Cells(x, 2).Value)
        Next
    End With
End Sub
'Private Sub getData()
'Dim o As New cClassSqlHelperForTableDB
'sql = "select 物料名称,sum(实收数量) as 数量,无税单价,round(sum(实收数量)*无税单价*1.09,2) as 含税金额 from [src$] where 物料名称 is not  null group by 物料名称,无税单价"
'Call o.ExecteFilterOverRideThree(sql, 2, 1, 1, 1, "res")
'End Sub
'Sub getSrcData() '分类汇总
'Dim o As New cClassSqlHelperForTableDB
'sql = "select 物料名称,sum(实收数量) as 数量,无税单价,round(无税单价*1.09,3) as 含税单价" _
    '& ",round(round(无税单价*1.09,3)*sum(实收数量),2) as 含税金额 from [src$] where 物料名称 is not  null group by 物料名称,无税单价"
'Call o.ExecteFilterOverRideThree(sql, 2, 1, 1, 1, "res")
'End Sub
'Sub getSrcData() '分类汇总
'Dim o As New cClassSqlHelperForTableDB
'sql = "select null as 序号,物料名称,sum(实收数量) as 数量,round(无税单价*1.09,3) as 含税单价" _
    '& ",round(round(无税单价*1.09,3)*sum(实收数量),2) as 含税金额 from [src$] where 物料名称 is not  null group by 物料名称,无税单价"
'Call o.ExecteFilterOverRideThree(sql, 2, 1, 1, 1, "res")
'Call addNumber
'End Sub
Sub 单位2()                                                  '从工作表获取单位
    Application.DisplayAlerts = False
    Set d = CreateObject("scripting.dictionary")
    With Sheets("count")
        ar = .Range("a1").CurrentRegion
    End With
    
    
    For x = 2 To UBound(ar)
        d(ar(x, 1)) = ar(x, 2)
    Next
    For Each sht In Sheets
        If IsNumeric(sht.Name) Then
            With Sheets(sht.Name)
                lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
                For x = 2 To lastrow
                    .Cells(x, 4) = d(.Cells(x, 2).Value)
                Next
            End With
        End If
    Next sht
    Application.ScreenUpdating = True
End Sub
Sub 单位()                                                   '从工作簿获取单位
    Application.DisplayAlerts = False
    Set d = CreateObject("scripting.dictionary")
    myPath = ThisWorkbook.path & "/22年2月明细.xls"
    With GetObject(myPath)
        ar = .Sheets("单位").[a1].CurrentRegion
        .Close False
    End With
    For x = 2 To UBound(ar)
        d(ar(x, 1)) = ar(x, 2)
    Next
    With Sheets("tax")
        lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For x = 2 To lastrow
            .Cells(x, 3) = d(.Cells(x, 1).Value)
        Next
    End With
    Application.ScreenUpdating = True
End Sub
Sub ExecteFilterOverRideThree(sq, resultInputStartRow, resultInputStartCol, HeaderStartRow, HeaderStartCol, wshResult)
    'sq      查询语句
    'resultInputStartRow  结果写入起始行
    'resultInputStartCol  结果写入起始列
    'HeaderStartRow    标题写入起始行
    'HeaderStartCol   标题写入起始列
    'wshResult  结果输出工作表
    Dim Conn As New Connection
    Dim arrGetSource As Variant
    Dim rs  As New ADODB.Recordset
    Dim arrTitle As Variant
    If Conn.State = 1 Then Conn.Close
    If rs.State = 1 Then rs.Close
    With Sheets(wshResult)
        .Range("a1:e65535").ClearContents
        Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=YES;IMEX=2';"
        '.Range(rg).CopyFromRecordset Conn.Execute(sq)
        .Cells(resultInputStartRow, resultInputStartCol).CopyFromRecordset Conn.Execute(sq)
        'arrGetSource = Conn.Execute(sq).GetRows
        rs.Open sq, Conn, adOpenKeyset, adLockOptimistic
        For j = 0 To rs.Fields.Count - 1
            .Cells(HeaderStartRow, j + HeaderStartCol) = rs.Fields(j).Name
        Next j
        .Cells.EntireColumn.AutoFit
    End With
    rs.Close
    Conn.Close
    Set rs = Nothing
    Set Conn = Nothing
End Sub
Sub ExecteFilterOverRideOne(sq, rg As String, rowNum, colNum, wshResult)
    'sq      查询语句
    'rg        查询结果写入起始单元格
    'rowNum    标题写入起始行
    'colNum   标题写入起始列
    'wshResult  结果输出工作表
    Dim Conn As New Connection
    Dim arrGetSource As Variant
    Dim rs  As New ADODB.Recordset
    Dim arrTitle As Variant
    With Sheets(wshResult)
        '.Cells.ClearContents
        Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=YES;IMEX=2';"
        .Range(rg).CopyFromRecordset Conn.Execute(sq)
        'arrGetSource = Conn.Execute(sq).GetRows
        rs.Open sq, Conn, adOpenKeyset, adLockOptimistic
        For j = 0 To rs.Fields.Count - 1
            .Cells(rowNum, j + colNum) = rs.Fields(j).Name
        Next j
        .Cells.EntireColumn.AutoFit
    End With
    Set Conn = Nothing
    Set rs = Nothing
End Sub
Function IsExists(findSheet As String, findField As String, findValue As String, targetPath)
    'findSheet 指定查找的表
    'findField  是判断的字段
    'findValue 是值
    'targetPath 数据要插入的工作簿的路径
    Dim Conn As New Connection
    Dim rst As New Recordset
    Dim SQL As String, arr
    If Conn.State = 1 Then cnn.Close
    If rst.State = 1 Then rs.Close
    Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & targetPath & ";Extended Properties='Excel 12.0;HDR=YES;IMEX=2';"
    SQL = "Select * from " & findSheet & " where " & findField & "='" & findValue & "'"
    rst.Open SQL, Conn, 1, 1
    If rst.RecordCount = 0 Then
        IsExists = False
    Else
        IsExists = True
    End If
    Set rst = Nothing
    Set Conn = Nothing
End Function
Sub 执行sql命令(sq As String, targetPath)
    Dim Conn As New Connection
    Dim rst As New Recordset
    If Conn.State = 1 Then cnn.Close
    If rst.State = 1 Then rs.Close
    Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & targetPath & ";Extended Properties='Excel 12.0;HDR=YES;IMEX=0';"
    Conn.Execute (sq)
    Set rst = Nothing
    Set Conn = Nothing
End Sub
Function getQueryOneResult(sq)
    Dim Conn As New Connection
    Dim arrGetSource As Variant
    Dim rs  As New ADODB.Recordset
    Dim arrTitle As Variant
    If Conn.State = 1 Then Conn.Close
    If rs.State = 1 Then rs.Close
    Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=YES;IMEX=2';"
    temp = Conn.Execute(sq).GetRows
    getQueryOneResult = temp(0, 0)
    rs.Open sq, Conn, adOpenKeyset, adLockOptimistic
    rs.Close
    Conn.Close
    Set rs = Nothing
    Set Conn = Nothing
End Function
Sub ExecteFilterOverRideThreeContainPath(sq, myPath, resultInputStartRow, resultInputStartCol, HeaderStartRow, HeaderStartCol, wshResult)
    'sq      查询语句
    'resultInputStartRow  结果写入起始行
    'resultInputStartCol  结果写入起始列
    'HeaderStartRow    标题写入起始行
    'HeaderStartCol   标题写入起始列
    'wshResult  结果输出工作表
    Dim Conn As New Connection
    Dim arrGetSource As Variant
    Dim rs  As New ADODB.Recordset
    Dim arrTitle As Variant
    If Conn.State = 1 Then Conn.Close
    If rs.State = 1 Then rs.Close
    With Sheets(wshResult)
        '.Cells.ClearContents
        Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myPath & ";Extended Properties='Excel 12.0;HDR=YES;IMEX=2';"
        '.Range(rg).CopyFromRecordset Conn.Execute(sq)
        .Cells(resultInputStartRow, resultInputStartCol).CopyFromRecordset Conn.Execute(sq)
        'arrGetSource = Conn.Execute(sq).GetRows
        rs.Open sq, Conn, adOpenKeyset, adLockOptimistic
        For j = 0 To rs.Fields.Count - 1
            .Cells(HeaderStartRow, j + HeaderStartCol) = rs.Fields(j).Name
        Next j
        .Cells.EntireColumn.AutoFit
    End With
    rs.Close
    Conn.Close
    Set rs = Nothing
    Set Conn = Nothing
End Sub
Sub 执行筛选(sq, rg As String, pathstr, rowNum)                'sql查询语句,查询结果写入起始处,工作簿路径全名,标题写入起始处
    Dim Conn As New Connection
    Dim arrGetSource As Variant
    Dim rs  As New ADODB.Recordset
    Dim arrTitle As Variant
    With ActiveSheet
        Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & pathstr & ";Extended Properties='Excel 12.0;HDR=YES;IMEX=2';"
        .Range(rg).CopyFromRecordset Conn.Execute(sq)
        arrGetSource = Conn.Execute(sq).GetRows
    End With
    rs.Open sq, Conn, adOpenKeyset, adLockOptimistic
    With ActiveSheet
        For j = 0 To rs.Fields.Count - 1
            .Cells(rowNum, j + 1) = rs.Fields(j).Name
        Next j
    End With
    Set Conn = Nothing
    Set rs = Nothing
End Sub
Sub ExecteFilter(sq, rg As String, pathstr, rowNum)
    Dim Conn As New Connection
    Dim arrGetSource As Variant
    Dim rs  As New ADODB.Recordset
    Dim arrTitle As Variant
    Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & pathstr & ";Extended Properties='Excel 12.0;HDR=YES;IMEX=2';"
    rs.Open sq, Conn, 1, 1
    If rs.RecordCount Then
        With ActiveSheet
            .Range(rg).CopyFromRecordset Conn.Execute(sq)
            For j = 0 To rs.Fields.Count - 1
                .Cells(rowNum, j + 1) = rs.Fields(j).Name
            Next j
            r = .Cells(Rows.Count, 1).End(3).Row
            l = .Cells(1, Columns.Count).End(xlToLeft).Column
            .[a1].Resize(r, l).Borders.LineStyle = 1
            .Range("A1:Q" & r).HorizontalAlignment = xlCenter
            .Range("A1:Q" & r).VerticalAlignment = xlCenter
        End With
    End If
    Set Conn = Nothing
    Set rs = Nothing
End Sub
Sub ExecteFilterOverRideFourContainPathNotClearContent(myPath, sq, resultInputStartRow, resultInputStartCol, HeaderStartRow, HeaderStartCol, wshResult)
    'sq      查询语句
    'resultInputStartRow  结果写入起始行
    'resultInputStartCol  结果写入起始列
    'HeaderStartRow    标题写入起始行
    'HeaderStartCol   标题写入起始列
    'wshResult  结果输出工作表
    Dim Conn As New Connection
    Dim arrGetSource As Variant
    Dim rs  As New ADODB.Recordset
    Dim arrTitle As Variant
    If Conn.State = 1 Then Conn.Close
    If rs.State = 1 Then rs.Close
    With Sheets(wshResult)
        '.Cells.ClearContents
        Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myPath & ";Extended Properties='Excel 12.0;HDR=YES;IMEX=2';"
        '.Range(rg).CopyFromRecordset Conn.Execute(sq)
        .Cells(resultInputStartRow, resultInputStartCol).CopyFromRecordset Conn.Execute(sq)
        'arrGetSource = Conn.Execute(sq).GetRows
        rs.Open sq, Conn, adOpenKeyset, adLockOptimistic
        For j = 0 To rs.Fields.Count - 1
            .Cells(HeaderStartRow, j + HeaderStartCol) = rs.Fields(j).Name
        Next j
        .Cells.EntireColumn.AutoFit
    End With
    rs.Close
    Conn.Close
    Set rs = Nothing
    Set Conn = Nothing
End Sub
Function 执行筛选重写转置成标准数组适用Access数据库(sq)
    Dim Conn As Object
    Set Conn = CreateObject("adodb.connection")
    Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.path & "/Database/PICC.mdb"
    '        .Range(rg).CopyFromRecordset Conn.Execute(sq)
    arrGetSource = Conn.Execute(sq).GetRows
    执行筛选重写转置成标准数组 = RowColumnTranspose(arrGetSource)
    Conn.Close
    Set Conn = Nothing
End Function
Function RowColumnTranspose(tempArr)                       '行列转置
    ReDim resultArr(UBound(tempArr, 2), UBound(tempArr))
    For i = 0 To UBound(tempArr)
        For j = 0 To UBound(tempArr, 2)
            If Not IsNull(tempArr(i, j)) Then resultArr(j, i) = tempArr(i, j)
        Next
    Next
    RowColumnTranspose = resultArr
End Function
Sub 拆分为工作簿()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '    currentTime = Format(Now(), "yyyy-MM-dd-hh-mm-ss")
    Dim Mbook As Workbook, i&
    Set Mbook = ThisWorkbook
    start_end_date = Sheets("tax").Range("e2")
    jine = Sheets("tax").Range("f2")
    For Each sht In Sheets
        '    If InStr(sht.Name, "fin") > 0 Then
        If IsNumeric(sht.Name) Then
            With Sheets(sht.Name)
                temname = getFenLeiID(sht.Name)
                '                str_date = Format(Now(), "yyyy-MM-dd-hh-mm-ss")
                str_date = Format(Now(), "yyyyMMddhhmmss") & "-" & start_end_date & "-" & jine
                res_wb_name = str_date & "_" & temname & "_" & sht.Name
                resFilePath = ThisWorkbook.path & "\res"
                Call isExistsFolderAndCreateFolder(resFilePath)
                If Len(.Range("a2")) > 0 Then
                    myPath = ThisWorkbook.path & "\res\" & sht.Name & ".xlsx"
                    killOldSheet (myPath)
                    Mbook.Worksheets(sht.Name).Copy
                    ActiveWorkbook.ActiveSheet.Name = "清单项目"
                    currentTime = Format(Now(), "yyyyMMddmmhhss")
                    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.path & "\res\" & res_wb_name & ".xlsx"
                    ActiveWindow.Close
                End If
            End With
        End If
    Next sht
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Sub isExistsFolderAndCreateFolder(file_path)
    If Dir(file_path, vbDirectory + vbHidden) = "" Then
        MkDir file_path & "\"
    End If
    '    MsgBox Dir("C:\Test\Test1", vbDirectory + vbHidden) <> ""
    '    MsgBox Dir("C:\Test\Test.txt", vbNormal + vbHidden + vbReadOnly) <> ""
End Sub
Sub 新建文件夹()
    On Error GoTo errHandle
    MkDir "C:\Test\"
    MkDir "C:\Test\Test1\"
    MkDir "C:\Test\Test2\"
    RmDir "C:\Test\Test2"
    Exit Sub
errHandle:
    MsgBox Err.Description
    Resume Next
End Sub
Private Function getFenLeiID(shtName)
    With Sheets(shtName)
        s = .[a2]
        If s = "1010112040000000000" Then
            getFenLeiID = "91120110MA05LB1Y06_清单项目_蔬菜"
        ElseIf s = "1010115010500000000" Then
            getFenLeiID = "91120110MA05LB1Y06_清单项目_水果"
        End If
    End With
End Function
'Sub 拆分为工作簿()
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
'Dim Mbook As Workbook, i&
'Set Mbook = ActiveWorkbook
'For i = 6 To Mbook.Worksheets.Count
'
''ActiveWorkbook.SaveAs Filename:="F:\i.邮件管理\门店月度进货对账单\" & Mbook.Worksheets(i).Name & ".xlsx"
'myPath = ThisWorkbook.path & "\res\" & Mbook.Worksheets(i).Name & ".xlsx"
'killOldSheet (myPath)
'Mbook.Worksheets(i).Copy
'ActiveWorkbook.SaveAs Filename:=ThisWorkbook.path & "\res\" & Mbook.Worksheets(i).Name & ".xlsx"
'ActiveWindow.Close
'Next i
'Application.ScreenUpdating = True
'Application.DisplayAlerts = True
'End Sub
Private Sub killOldSheet(path)
    If Dir(path) <> "" Then Kill path
End Sub
Private Sub 循环分类汇总()
    Application.DisplayAlerts = False
    For Each sht In Sheets
        sht_name = sht.Name
        If IsNumeric(sht_name) Then
            param1 = sht_name
            param2 = "fin" & sht_name
            Call subtotal(param1, param2)
            formated (param2)
        End If
    Next sht
    Application.DisplayAlerts = True
End Sub
Private Sub subtotal(p1, p2)
    'sql = "select 税收分类编码,商品名称,规格型号,计量单位,sum(数量) as 数量,avg(单价) as 单价,sum(金额) as 金额,税率,优惠政策,免税类型,含税标志 from [清单项目$] group by 税收分类编码,商品名称"
    SQL = "select 税收分类编码,商品名称,规格型号,计量单位,sum(数量) as 数量," _
        & "round(avg(单价),5) as 单价,(sum(数量)*round(avg(单价),5)) as 金额,avg(税率) as 税率 from [" & p1 & "$] group by 税收分类编码,商品名称,规格型号,计量单位"
    Call ExecteFilterOverRideThree(SQL, 2, 1, 1, 1, p2)
    'Call formated
End Sub
Private Sub formated(p2)
    With Sheets(p2)
        .Columns("f:f").NumberFormatLocal = "0.00000"
    End With
End Sub
'Private Sub ExecteFilterOverRideThree(sq, resultInputStartRow, resultInputStartCol, HeaderStartRow, HeaderStartCol, wshResult)
'    'sq      查询语句
'    'resultInputStartRow  结果写入起始行
'    'resultInputStartCol  结果写入起始列
'    'HeaderStartRow    标题写入起始行
'    'HeaderStartCol   标题写入起始列
'    'wshResult  结果输出工作表
'    Dim Conn As New Connection
'    Dim arrGetSource As Variant
'    Dim rs  As New ADODB.Recordset
'    Dim arrTitle As Variant
'    If Conn.State = 1 Then Conn.Close
'    If rs.State = 1 Then rs.Close
'    With Sheets(wshResult)
'        '.Cells.ClearContents
'        Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=YES;IMEX=2';"
'        '.Range(rg).CopyFromRecordset Conn.Execute(sq)
'        .Cells(resultInputStartRow, resultInputStartCol).CopyFromRecordset Conn.Execute(sq)
'        'arrGetSource = Conn.Execute(sq).GetRows
'        rs.Open sq, Conn, adOpenKeyset, adLockOptimistic
'        For j = 0 To rs.Fields.Count - 1
'            .Cells(HeaderStartRow, j + HeaderStartCol) = rs.Fields(j).Name
'        Next j
'        .Cells.EntireColumn.AutoFit
'    End With
'    rs.Close
'    Conn.Close
'    Set rs = Nothing
'    Set Conn = Nothing
'End Sub