Excel VBA 把对账单按照订单号单独保存为发票导入清单
本帖最后由 szllw 于 2020-4-13 12:17 编辑客户发来的对账单，需要按照对账单开票，由于数量众多，手工分列文件效率慢又容易出错。所以写了一段代码，把对账单按照一个订单号码保存为一个文件，并且需要可以被发票清单导入工具导入。
1、客户发来的对账单（部分截图）：
2、使用方法：
注意：
（1）不要修改【导出摸板 (TEST)】中的任何内容，任何修改，都会导致导出错误
（2）不要删除【当前开票对账单】中的任何行，只能选中后按del键删除内容，也不能移动内容，否则会导致主表格错误。
（3）打开文件必须要【启用宏】。
a）把客户发来的对账单按照标题行一一对应的复制内容到第二个表格【当前开票对账单】；b）转到【导出摸板 (TEST)】，点击定位空白行（这个步骤是因为客户发过来的名称可能有不符合发票系统名称的，需要把他添加到数据库A和数据库B中，添加内容后需要排序，因为用到的lookup函数是以二分查找法来查找，所以需要排序）；
c）数据库A是把对账单的不符合发票系统名称转为统一名称，数据库B是用来查找单位的，因为客户发来的单位都是pc、ea、set、bag等，不符合中国人开票习惯；
d）在定位空白行移动到最后一行后，表示没有不符合发票标准的名称了（这个要按照你们发票系统的名称来修改）；
e）打开宏，选择：导出清单___A一键导出发票清单★★★，即可在文件当前目录自动新建一个目录，目录下保存为以订单号为文件名的文件，这些文件都可以被发票清单导入工具导入（如有需要，请按照当地的发票系统修改相应代码）。
3、以下为导出的分列发票清单文件：
下面是其中一个发票清单的内容：
4、模板下载：
5、以下为代码：
Sub 导出清单___A一键导出发票清单★★★()
'**************************************************************
'* 功能：对账单一键导出所有发票清单 *
'* 作者：LLW *
'* 创建时间：2019-3-26 *
'* 版本：1.42020-03-23 功能修正：导出模板变更 *
'* 版本：1.32019-11-19 修复：订单号为文本时的运行错误 *
'* 版本：1.22019-04-18 增加：订单号清单追加序号列 *
'* 版本：1.12019-03-28 增加：包含导出发票订单号清单 *
'* 版本：1.02019-03-26 增加：一键导出所有发票清单 *
'**************************************************************
'简单判断是否导出表，否则就不运行
If (Range("K1").Value <> "订单号") Then
MsgBox ("不能在这个表操作，请到【导出摸板 (TEST)】操作")
End
End If
'***************************************************************
'***** 当对账单订单号码以文本格式保存时，程序运行出错 *****
'***** 把文本转为数字时解决错误。2019/11/19 *****
'***************************************************************
Sheets("当前开票对账单").Select
With Intersect(ActiveSheet.UsedRange, )
.NumberFormatLocal = "G/通用格式"
.Value = .Value
End With
Sheets("导出摸板 (TEST)").Select
'***************************************************************
'获得当前表的名称
Dim curWbName As String
curWbName = ActiveSheet.Name
'********** 清除筛选 **********
'判断筛选状态
If Sheets(curWbName).AutoFilterMode = True Then
'不论当前是否是筛选状态，保证A1所在区域成为筛选状态
Range("A1").AutoFilter Field:=1
'解除筛选状态。（注意因为上一句代码，已经保证成为筛选状态了）
Range("A1").AutoFilter
'ActiveSheet.ShowAllData
Range("A1").Select
End If
'*****************************
Dim arr
arr = Range("A1:K" & .End(3).Row)
'定义变量
Dim i As Long, wName As String, wPath As String
'建立的文件夹名称
wName = "发票清单 " & Format(Date)
'定义变量
Dim dc As Object, wb As Workbook, n As Long
Set dc = CreateObject("Scripting.dictionary")
'工作路径
wPath = ThisWorkbook.Path & "\" & wName
'建立目录
If Dir(wPath, vbDirectory) = "" Then
MkDir wPath
End If
'序号赋值到新表格
Dim No
No = 1
Dim curOrder, preOrder
curOrder = arr(2, 11) 'arr(2, 11) 第2行，第11列
'************ 把发票总清单中的内容以订单号为文件名单独导出保存 ************
'循环开始
For i = 2 To UBound(arr)
If arr(i, 11) = 0 Then '如果订单号是0，则退出循环
No = 1
Workbooks(curOrder & ".xls").Close True
Exit For
End If
If Not arr(i, 11) = arr(i - 1, 11) Then '如果当前订单号和上一条订单号不相同，则
'把当前订单号赋值给上一订单号，后面用过来关闭文件
If Not arr(i - 1, 11) = "订单号" Or arr(i - 1, 11) = 0 Then
preOrder = curOrder
End If
curOrder = arr(i, 11)
'关闭并保存前订单文件
If Not preOrder = "" Then
Workbooks(preOrder & ".xls").Activate '切换到要关闭的工作表
'*******文字居中********
Columns("B:I").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Range("A2").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Columns("A:A").ColumnWidth = 38.38
Rows(1).AutoFit
Columns("B:I").EntireColumn.AutoFit
'*******文字居中********
Workbooks(preOrder & ".xls").Close True '003
End If
'序号在新文件中初始化为1
No = 1
'新建表格
Set wb = Workbooks.Add
'设置表的名称
wb.Sheets(1).Name = arr(i, 11)
'********** 以03格式保存xls文件 **********
wb.SaveAs Filename:=wPath & "\" & arr(i, 11) & ".xls", FileFormat:=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
'********** 以07或以上格式保存xlsx文件 **********
'wb.SaveAs Filename:=wPath & "\" & arr(i, 11) & ".xlsx", FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
'********** 保存文件，默认xlsx格式 **********
'wb.SaveAs wPath & "\" & arr(i, 11) & ".xlsx" '001
End If
'************ 填写表头（标题行） ************
If Not dc.exists(arr(i, 11)) And No = 1 Then
Columns("A:A").ColumnWidth = 40
Cells(1, 1).Value = "注意：" & vbCrLf & " 1、模板中最多可录入2000行记录，超出的部分将在导入时被舍弃。" & vbCrLf & " 2、红颜色标示的字段为必填列 " '提示：注意"
Cells(1, 4).Value = "不含税金额"
Cells(1, 5).Formula = "=SUM(G3:G2002)"
Cells(1, 6).Value = "行数"
Cells(1, 7).Formula = "=COUNTA(A3:A2002)"
Cells(1, 8).Value = "总金额"
Cells(1, 9).Formula = "=SUM(I3:I2002)"
wb.Sheets(1). = arr(1, 2) '商品名称
wb.Sheets(1). = arr(1, 3) '规格
wb.Sheets(1). = arr(1, 4) '单位
wb.Sheets(1). = arr(1, 5) '数量
wb.Sheets(1). = arr(1, 6) '不含税单价
wb.Sheets(1). = arr(1, 7) '税率
wb.Sheets(1). = arr(1, 8) '不含税金额
wb.Sheets(1). = arr(1, 9) '税额
wb.Sheets(1). = arr(1, 10) '价税合计
'wb.Sheets(1). = arr(1, 11) '新表不需要订单号
'自适应所有列宽
'Columns("A:I").Select '选择列
'Rows(1).RowHeight = 40
'Columns("A:A").ColumnWidth = 40
'Rows(1).AutoFit
'Columns("B:I").EntireColumn.AutoFit
'Rows(1).EntireColumn.AutoFit
End If
'************ 数据填充 ************
With Workbooks(arr(i, 11) & ".xls").Sheets(1) '002
n = ..End(3).Row + 1
.Cells(n, 1) = arr(i, 2) '商品名称
If No = 1 Then
.Cells(n, 2) = "项目" & arr(i, 3) '规格(第一个项目加上文本)
Else
.Cells(n, 2) = arr(i, 3)
End If
.Cells(n, 3) = arr(i, 4) '单位
.Cells(n, 4) = arr(i, 5) '数量
.Cells(n, 5) = arr(i, 6) '不含税单价
.Cells(n, 6) = 0.13 '税率 (固定值：0.13)
.Cells(n, 7).Formula = "=ROUND(D" & No + 2 & "*E" & No + 2 & ",2)" '不含税金额 (公式)
.Cells(n, 8).Formula = "=ROUND(D" & No + 2 & "*E" & No + 2 & "*F" & No + 2 & ",2)" '税额 (公式)
.Cells(n, 9).Formula = "=G" & No + 2 & "+H" & No + 2 '价税合计 (公式)
End With
No = No + 1
Next
'循环结束
'*********************** 生成数据透视表 **********************
Dim nFpList
'建立的文件夹名称
nFpList = "订单号清单_" & Format(Date)
'在创建透视表时，表名不能包含"-"符号，替换成下划线
nFpList = Replace(nFpList, "-", "_")
'定义都是表的变量
Dim nPivotTables
'设定透视表类型：4,6
nPivotTables = "数据透视表1"
'全部选择
Cells.Select
'复制选中的范围
Selection.Copy
'新建文件
Workbooks.Add
'给新建文件名设置表名
Sheets("Sheet1").Name = "数据清单"
'文本方式粘贴内容
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'自动适应列宽
Columns("A:R").EntireColumn.AutoFit
Columns("L:R").Select '删除无用信息：不含税金额135579.86 行数 2000 总金额153205.45
Selection.Delete Shift:=xlToLeft
'复制区域边缘不闪动
Application.CutCopyMode = False
'新建表
Sheets.Add
'给透视表设置表名
Sheets("Sheet2").Name = nFpList
'建立透视表 Version DefaultVersion xlPivotTableVersion10
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"数据清单!R1C1:R2003C11", Version:=6).CreatePivotTable TableDestination _
:=nFpList & "!R3C1", TableName:=nPivotTables, DefaultVersion:=6
'透视表操作
Sheets(nFpList).Select
Cells(3, 1).Select
With ActiveSheet.PivotTables(nPivotTables).PivotFields("订单号")
.Orientation = xlRowField
.Position = 1
End With
'添加数量和金额字段
ActiveSheet.PivotTables(nPivotTables).AddDataField ActiveSheet.PivotTables(nPivotTables).PivotFields("数量"), "计数项:数量", xlCount
ActiveSheet.PivotTables(nPivotTables).AddDataField ActiveSheet.PivotTables(nPivotTables).PivotFields("不含税金额"), "求和项:不含税金额", xlSum
'筛选取消订单号为0、为空的选项
With ActiveSheet.PivotTables(nPivotTables).PivotFields("订单号")
.PivotItems("0").Visible = False
.PivotItems("(blank)").Visible = False
End With
'选取一个表的所有范围
Cells.Select
'复制
Selection.Copy
'文本粘贴
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'删除“数据清单”表
Application.DisplayAlerts = False
Sheets("数据清单").Delete
Application.DisplayAlerts = True
'选择第1,2行
Rows("1:2").Select
'删除第一第二无用的行
Selection.Delete Shift:=xlUp
'修改字段名称
Cells(1, 1).Value = "订单号"
Cells(1, 2).Value = "项数"
Cells(1, 3).Value = "金额"
Cells(1, 4).Value = "发票"
Cells(1, 5).Value = "清单"
'添加序号列
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.FormulaR1C1 = "序号"
'************以计数项排序*************
Range("A1:F100").Select
ActiveWorkbook.Worksheets(nFpList).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(nFpList).Sort.SortFields.Add2 Key:=Range("C2:C100"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'ActiveWorkbook.Worksheets(nFpList).Sort.SortFields.Add2 Key:=Range("B2:C" & i), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(nFpList).Sort
.SetRange Range("A1:F100")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'************************************
Range("A2").Select
'遇到总计就退出,遇到有内容就编号
For i = 1 To 100
If Cells(i + 1, "B") = "总计" Then
Exit For
ElseIf Not Cells(i + 1, "B") = "" Then
Cells(i + 1, "A").Value = i
End If
Next i
'************************↓设置细表格↓************************
Range("A1:F" & i + 1 & "").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
'************************↑设置细表格↑************************
'设置字体和大小
Columns("A:F").Select
With Selection.Font
.Name = "等线"
.Size = 20
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
'设置行高
Rows("1:100").Select
Selection.RowHeight = 35
'设置列宽
Columns("A").ColumnWidth = 8.2 '序号
Columns("B").ColumnWidth = 20 '订单
Columns("C").ColumnWidth = 10 '项数
'Columns("D").ColumnWidth = 11 '金额
Columns("D").EntireColumn.AutoFit '金额项金额变化，需要自动适配宽度
Columns("E").ColumnWidth = 15 '发票
Columns("F").ColumnWidth = 15 '清单
'整个表格文字左右居中
Columns("A:F").Select
With Selection
.HorizontalAlignment = xlCenter '左右居中
.VerticalAlignment = xlCenter '上下居中
End With
'金额项数字部分右对齐，标题居中
Columns("D").Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
End With
Range("D1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
'******************************
'设置页边距
With Sheets(nFpList).PageSetup
.LeftMargin = Application.InchesToPoints(0.196850393700787)
.RightMargin = Application.InchesToPoints(0.196850393700787)
.TopMargin = Application.InchesToPoints(0.590551181102362)
.BottomMargin = Application.InchesToPoints(0.196850393700787)
.HeaderMargin = Application.InchesToPoints(0.196850393700787)
.FooterMargin = Application.InchesToPoints(0.236220472440945)
.CenterHorizontally = True'水平居中
End With
Range("A1").Select
'保存文件
'ChDir "C:\Users\" & Environ("username") & "\Desktop\"
ActiveWorkbook.SaveAs Filename:=wPath & "\订单号清单 " & Format(Date) & ".xls", FileFormat:=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
End Sub
wubwu33 发表于 2020-4-12 19:31
楼主，代码是用什么软件编辑的？
Office中的Word、Excel自带VB编辑器
guorenming111 发表于 2021-10-20 11:24
如果发票超额，要拆分每张发票不超过10W的拆分，有工具的吗？
另写代码，每行金额相加，在下一行超过10W时，则截止到当前行导出。 谢谢楼主分享！ 好人一生平安 楼主，代码是用什么软件编辑的？ 实用性很高，感谢楼主分享 谢谢分享！ 感谢分享 学习借鉴一下，谢谢分享 这是个好东西