[Visual Basic] 纯文本查看 复制代码
Sub 导出清单___A一键导出发票清单★★★()
'**************************************************************
'* 功能：对账单一键导出所有发票清单 *
'* 作者：LLW *
'* 创建时间：2019-3-26 *
'* 版本：1.4 2020-03-23 功能修正：导出模板变更 *
'* 版本：1.3 2019-11-19 修复：订单号为文本时的运行错误 *
'* 版本：1.2 2019-04-18 增加：订单号清单追加序号列 *
'* 版本：1.1 2019-03-28 增加：包含导出发票订单号清单 *
'* 版本：1.0 2019-03-26 增加：一键导出所有发票清单 *
'**************************************************************
'简单判断是否导出表，否则就不运行
If (Range("K1").Value <> "订单号") Then
MsgBox ("不能在这个表操作，请到【导出摸板 (TEST)】操作")
End
End If
'***************************************************************
'***** 当对账单订单号码以文本格式保存时，程序运行出错 *****
'***** 把文本转为数字时解决错误。 2019/11/19 *****
'***************************************************************
Sheets("当前开票对账单").Select
With Intersect(ActiveSheet.UsedRange, [A:A])
.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" & [a65536].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).[a2] = arr(1, 2) '商品名称
wb.Sheets(1).[b2] = arr(1, 3) '规格
wb.Sheets(1).[c2] = arr(1, 4) '单位
wb.Sheets(1).[d2] = arr(1, 5) '数量
wb.Sheets(1).[e2] = arr(1, 6) '不含税单价
wb.Sheets(1).[f2] = arr(1, 7) '税率
wb.Sheets(1).[g2] = arr(1, 8) '不含税金额
wb.Sheets(1).[h2] = arr(1, 9) '税额
wb.Sheets(1).[i2] = arr(1, 10) '价税合计
'wb.Sheets(1).[j2] = 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 = .[a65536].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
[复制链接]
发表于 2020-4-12 18:59
|
发表于 2020-4-12 19:37
