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
浙公网安备 33010602011771号