前二天，给财务部做了个数据采集的工具，因为财务现在用的是excel2013 和2017的版本，所以我决定不用python，改用VBA来处理这个工具。
在 写过程的时候，我用了sheets(i)来定位表，写了好几个过程后，在最后整理过程的时候还好，如果写完再修改的话，会有一些麻烦。
因为sheets(i)已经限定了这个表，所以后期一旦修改的话，就会有很问题，因为要操作的表，并不一定是sheets(i).
后来实在没有办法了，我就用activesheets(i), 来替代这个sheets(i), 这样就会少去很多麻烦。
Sub 处理所有的预算文件夹下的数据为一维表() '处理所有的预算文件夹下的数据为一维表 Application.ScreenUpdating = False
Application.DisplayAlerts = False
'获取当前文件夹所有文件
Folder = ActiveWorkbook.Path & "\"
AWbName = ActiveWorkbook.Name '当前工作表的名字
Filename = Dir(Folder)
MyPath = Folder & AWbName
While Filename <> AWbName And Filename <> "合并后的预算二维表总表.xlsm"
Set Wb = Workbooks.Open(Folder & Filename) '此处写要处理文件的逻辑代码 '以下是处理预算的逻辑
Call 处理预算数据 '下面是处理业绩的逻辑
'Call 处理业绩数据 ' Debug.Print Filename
Wb.Save
Wb.Close False
Filename = Dir
Wend Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "处理完毕！"
End Sub Sub 处理所有的业绩文件夹下的数据为一维表() '处理所有的预算文件夹下的数据为一维表 Application.ScreenUpdating = False
Application.DisplayAlerts = False '获取当前文件夹所有文件
Folder = ActiveWorkbook.Path & "\"
AWbName = ActiveWorkbook.Name '当前工作表的名字
Filename = Dir(Folder)
MyPath = Folder & AWbName
While Filename <> AWbName And Filename <> "合并后的业绩二维表总表.xlsm"
Set Wb = Workbooks.Open(Folder & Filename) '此处写要处理文件的逻辑代码 '以下是处理预算的逻辑
'Call 处理预算数据 '下面是处理业绩的逻辑
Call 处理业绩数据 ' Debug.Print Filename
Wb.Save
Wb.Close False
Filename = Dir
Wend Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "处理完毕！"
End Sub '======================================
Sub 处理预算数据()
'====================================== Application.ScreenUpdating = False
Application.DisplayAlerts = False '获取有数据的最大行数 max_row_A = Sheets(1).Range("a65536").End(xlUp).Row '复制第一张工作做为副本放到最后
Sheets(1).Select
Sheets(1).Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Select '先删除汇总和人员配备所在的行 因为一维表用不到这两行数据
ActiveSheet.Range("A" & max_row_A).EntireRow.Delete
'ActiveSheet.Range("A" & max_row_A - 1).EntireRow.Delete 'Debug.Print max_row 'Range("a" & 11).Select 'Range("G4:AQ1").Select
'Selection.Delete '===========================处理每月数据START================================================= For i = 7 To 39 Step 3 '复制每月的数据
Range(Cells(7, i), Cells(max_row_A, i + 2)).Cut '判断d列有数据的行数,以便粘贴月份的数据
max_row_D = Sheets(Sheets.Count).Range("d65536").End(xlUp).Row '选择要粘贴的月份的单元格，开始粘贴,这里max_row+2是因为最后一行数据是空，所以要再加1
'此处要判断一下单元A列与D列的有数据的行，因为D列的最后一行数据有空行的出现
If max_row_A = max_row_D Then
Range("D" & max_row_D + 1).Select
ActiveSheet.Paste
Else
Range("D" & max_row_D + 1).Select
ActiveSheet.Paste End If Next
'===========================处理每月数据END================================================= '判断a列有数据的行数(主要是取表头的数据)不能放在
Application.CutCopyMode = False
max_row_b = Sheets(Sheets.Count).Range("a65536").End(xlUp).Row
Set data_hear = Range(Cells(7, 1), Cells(max_row_b, 3))
'Set data_tail = Range(Cells(7, 43), Cells(max_row_b, 43)) For k = 1 To 11
' Debug.Print Sheets(1).Range("d65536").End(xlUp).Row
If Sheets(Sheets.Count).Range("d65536").End(xlUp).Row <> 0 Then '判断a列有数据的行数
'max_row_b = Sheets(1).Range("a65536").End(xlUp).Row
'处理表头的数据
data_hear.Copy
'data_tail.Copy max_row_A = Sheets(Sheets.Count).Range("a65536").End(xlUp).Row
'选择要粘贴的单元格
Range("a" & max_row_A + 1).Select '开始粘贴
ActiveSheet.Paste End If
Next
'删除表头的内容，让右则的单元格来补充
Range("G6:BO6").Select
Selection.Delete Shift:=xlToLeft
Range("A7").Select '增加预算年、预算月、数据来源
'===================处理年份start================================================ '写入汇率数据和月份
Range("J6") = "数据来源"
Range("I6") = "预算月"
Range("H6") = "预算年" '************************ '设置Q列的数据格式为数值类型 Columns("Q:Q").Select Selection.NumberFormatLocal = "0_);[红色](0)" '设置G列的格式为文本类型---预算年
Columns("G:G").Select
Selection.NumberFormatLocal = "@" r = Range("b65536").End(xlUp).Row
For P = 7 To r
Range("H" & P) = Year(Date) '处理预算年的值
Range("J" & P) = Application.ActiveWorkbook.Name '处理数据来源的值 Next
'===================处理年份end================================================ '===================处理月份start================================================ '处理月份 '插入月份，共有十二个月份，所以要循环12次，每个月份共有几行，要获取开始A列是最大有数据的行数 '先插入一列做为表头 interval = (r - 6) / 12
end_index = 12 * interval + 1
start_index = 1
For t = 1 To end_index - 1 Range("I" & t + 6) = start_index & "月" If t Mod interval = 0 Then start_index = start_index + 1
End If
Next '===================处理月份end================================================ '处理删除汇总列 Columns("AN:AP").Select
'Selection.Delete Shift:=xlToLeft '删除表头不用的数据 'Range("E3:I4").Select
'Selection.ClearContents '删除多余的行
Rows("2:3").Select
Range("A3").Activate
Selection.Delete Shift:=xlUp '===================删除汇总start================================================ '删除表中带有“汇总”字样的单元格所在的行 '获取C列有数据的最大行
max_row_c = Sheets(Sheets.Count).Range("A65536").End(xlUp).Row '循环判断单元格的值是否含有"汇总"字样，如果有，则删除当前行 "部门人员配备*" For x = max_row_c To 7 Step -1 If Range("A" & x).Value Like "*汇总" Then Range("A" & x).EntireRow.Delete End If Next '===================删除汇总end=================================================== '===================处理明年费用（支出）特别说明start========================== ' '
Application.CutCopyMode = False
max_row_b = Sheets(Sheets.Count).Range("AP65536").End(xlUp).Row Set data_tail = Range(Cells(5, 43), Cells(max_row_b, 43)) For G = 0 To 11
' Debug.Print Sheets(1).Range("b65536").End(xlUp).Row
If Sheets(Sheets.Count).Range("H65536").End(xlUp).Row <> Sheets(Sheets.Count).Range("G65536").End(xlUp).Row Then '判断a列有数据的行数
'max_row_b = Sheets(1).Range("a65536").End(xlUp).Row
'处理表头的数据 data_tail.Copy max_row_i = Sheets(Sheets.Count).Range("AQ65536").End(xlUp).Row '选择要粘贴的单元格
Range("G" & 5 + (max_row_b - 4) * G).Select '开始粘贴
ActiveSheet.Paste End If
Next
'===================处理明年费用（支出）特别说明end================================ '************************
'更改表头字段 Range("D4").Value = "当年预算数据"
Range("E4").Value = "当年实际数据"
Range("F4").Value = "明年预算数据"
Range("G4").Value = "明年费用（支出）预算特别说明" Sheets(1).Select '处理上面的格式 Application.ScreenUpdating = True
Application.DisplayAlerts = True 'Application.DisplayAlerts = False
'ActiveWorkbook.Save
'ActiveWorkbook.Close
'Application.DisplayAlerts = True End Sub Sub 处理业绩数据() Application.ScreenUpdating = False
Application.DisplayAlerts = False '获取有数据的最大行数,这里为什么用B65536呢，是因为A列的部门的值有很多是空值 ，所以统计不出来真实数值 max_row_A = Sheets(1).Range("b65536").End(xlUp).Row '复制第一张工作做为副本放到最后
Sheets(1).Select
Sheets(1).Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Select 'Debug.Print max_row 'Range("a" & 11).Select 'Range("G4:AQ1").Select
'Selection.Delete For i = 15 To 70 Step 5 '复制每月的数据
Range(Cells(6, i), Cells(max_row_A, i + 4)).Select
Range(Cells(6, i), Cells(max_row_A, i + 4)).Cut '判断j列有数据的行数,以便粘贴月份的数据
max_row_D = Sheets(Sheets.Count).Range("j65536").End(xlUp).Row '选择要粘贴的月份的单元格，开始粘贴,这里max_row+2是因为最后一行数据是空，所以要再加1
'此处要判断一下单元A列与D列的有数据的行，因为D列的最后一行数据有空行的出现
If max_row_A = max_row_D Then
Sheets(Sheets.Count).Range("j" & max_row_D + 1).Select
ActiveSheet.Paste
Else
Sheets(Sheets.Count).Range("j" & max_row_D + 1).Select
ActiveSheet.Paste End If Next '判断a列有数据的行数(主要是取表头的数据)不能放在
Application.CutCopyMode = False
max_row_b = Sheets(Sheets.Count).Range("b65536").End(xlUp).Row
Set data_hear = Range(Cells(6, 1), Cells(max_row_b, 4)) For k = 1 To 11
' Debug.Print Sheets(1).Range("j65536").End(xlUp).Row
'If Sheets(1).Range("j65536").End(xlUp).Row <> 0 Then '判断a列有数据的行数
'max_row_b = Sheets(1).Range("a65536").End(xlUp).Row
'处理表头的数据
data_hear.Copy max_row_A = Range("b65536").End(xlUp).Row '选择要粘贴的单元格
Range("a" & max_row_A + 1).Select '开始粘贴
ActiveSheet.Paste 'End If
Next '删除表头的内容，让右则的单元格来补充
Range("O3:BZ5").Select
Selection.Delete Shift:=xlToLeft
Range("A7").Select '写入汇率数据和月份
Range("Q5") = "明年平均汇率"
Range("P5") = "预算月"
Range("O5") = "预算年"
Range("R5") = "数据来源" '处理数据来源的值 '设置Q列的数据格式为数值类型 Columns("O:O").Select Selection.NumberFormatLocal = "0_);[红色](0)" '设置O列的格式为文本类型
Columns("Q:Q").Select
Selection.NumberFormatLocal = "@" r = Range("b65536").End(xlUp).Row
For P = 6 To r
Range("O" & P) = Year(Date)
Range("Q" & P) = Range("G3").Value
Range("R" & P) = Application.ActiveWorkbook.Name '处理数据来源的值 Next '处理月份 '插入月份，共有十二个月份，所以要循环12次，每个月份共有几行，要获取开始A列是最大有数据的行数 '先插入一列做为表头 interval = (r - 5) / 12
end_index = 12 * interval + 1
start_index = 1
For t = 1 To end_index - 1 Range("P" & t + 5) = start_index & "月" If t Mod interval = 0 Then start_index = start_index + 1
End If
Next '处理删除汇总列 Columns("E:I").Select
Selection.Delete Shift:=xlToLeft '删除表头不用的数据 Range("E3:I4").Select
Selection.ClearContents '删除多余的行
Rows("2:3").Select
Range("A3").Activate
Selection.Delete Shift:=xlUp '删除表中带有“小计”字样的单元格所在的行 '获取C列有数据的最大行
max_row_c = Sheets(Sheets.Count).Range("C65536").End(xlUp).Row '循环判断单元格的值是否含有"小计"字样，如果有，则删除当前行 For x = max_row_c To 4 Step -1 If Range("C" & x).Value Like "*小计" Then Range("C" & x).EntireRow.Delete End If If Range("B" & x).Value Like "*合计" Then Range("B" & x).EntireRow.Delete End If Next Sheets(1).Select Application.ScreenUpdating = True
Application.DisplayAlerts = True 'Application.DisplayAlerts = False
''file = ThisWorkbook.Path & "处理后的业绩一维表.xlsx"
''ActiveWorkbook.SaveAs Filename:=file
'
'Sheets(Sheets.Count).Save
'ActiveWorkbook.Close
'
'Application.DisplayAlerts = True End Sub Sub 生成全部_业绩_二维表() ' 业绩二维表的表头是五行，数据从第六行开始。
'而 预算二维表的表头是六行，数据是从第七行开始的 Dim MyPath, MyName, AWbName Dim Wb As Workbook, WbN As String Dim G As Long Dim Num As Long Dim BOX As String Application.ScreenUpdating = False
Application.DisplayAlerts = False MyPath = ActiveWorkbook.Path '获取当前文件所在的目录 MyName = Dir(MyPath & "\" & "*.xls*") '获取当前目录下的所有包含xls扩展名的文件 AWbName = ActiveWorkbook.Name '当前工作表的名字 Num = 0
'Cells.Delete Do While MyName <> "" If MyName <> AWbName Then If MyName <> "合并后的业绩一维表总表.xlsm" Then Set Wb = Workbooks.Open(MyPath & "\" & MyName) '**********************************************
'* *
'* 处理删除二维表中的所有汇总字段 *
'* ' *
'********************************************** '===================删除汇总start================================================ '删除表中带有“汇总”字样的单元格所在的行 '获取C列有数据的最大行
max_row_c = Sheets(1).Range("B65536").End(xlUp).Row
'Cells.Delete '循环判断单元格的值是否含有"汇总"字样，如果有，则删除当前行 "部门人员配备*" For x = max_row_c To 7 Step -1 If Range("C" & x).Value Like "*小计" Then Range("C" & x).EntireRow.Delete End If If Range("B" & x).Value Like "*合计" Then Range("B" & x).EntireRow.Delete End If Next '===================删除汇总end=================================================== '在没有复制之前，先把表头写上
Rows("1:5").Select
Rows("1:5").Copy Workbooks(1).ActiveSheet.Cells(1, 1) '写入表头 'Wb.Sheets(1).Range("A1:BQ5").Copy Workbooks(1).ActiveSheet.Cells(1, 1) '写入表头 Num = Num + 1 'Name是为了最后消息提示用的。
max_row = Wb.Sheets(1).Range("b65536").End(xlUp).Row
With Workbooks(1).ActiveSheet .Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4) For G = 1 To 1 'Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1) '带表头
Wb.Sheets(G).Rows("6:5000").Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1) '不带表头
'Wb.Sheets(G).Rows("6:" & .Range("B65536").End(xlUp).Row).Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1) '不带表头 'Wb.Sheets(G).Range("A6:BQ" & max_row).Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1) '不带表头 Next WbN = WbN & Chr(13) & Wb.Name Wb.Close False End With End If
End If MyName = Dir '获取下个文件名 Loop Range("B1").Select file = MyPath & "\合并后的业绩二维表总表.xlsm"
Workbooks(1).SaveAs Filename:=file 'Workbooks(1).SaveAs "2022年费用支出预算表.xlsx"
Application.ScreenUpdating = True
Application.DisplayAlerts = True MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
Application.Quit End Sub Sub 生成全部_预算_二维表() ' 业绩二维表的表头是五行，数据从第六行开始。
'而 预算二维表的表头是六行，数据是从第七行开始的 Dim MyPath, MyName, AWbName Dim Wb As Workbook, WbN As String Dim G As Long Dim Num As Long Dim BOX As String Application.ScreenUpdating = False
Application.DisplayAlerts = False MyPath = ActiveWorkbook.Path '获取当前文件所在的目录 MyName = Dir(MyPath & "\" & "*.xls*") '获取当前目录下的所有包含xls扩展名的文件 AWbName = ActiveWorkbook.Name '当前工作表的名字 Num = 0
'Cells.Delete Do While MyName <> "" If MyName <> AWbName Then If MyName <> "合并后的预算一维表总表.xlsm" Then Set Wb = Workbooks.Open(MyPath & "\" & MyName) '**********************************************
'* *
'* 处理删除二维表中的所有汇总字段 *
'* ' *
'********************************************** '===================删除汇总start================================================ '删除表中带有“汇总”字样的单元格所在的行 '获取C列有数据的最大行
max_row_c = Sheets(1).Range("B65536").End(xlUp).Row '循环判断单元格的值是否含有"汇总"字样，如果有，则删除当前行 "部门人员配备*" For x = max_row_c To 7 Step -1 ' If Range("C" & x).Value Like "*小计" Then
'
' Range("C" & x).EntireRow.Delete
If Range("A" & x).Value Like "*汇总" Then Range("A" & x).EntireRow.Delete End If If Range("C" & x).Value Like "部门人员配备*" Then Range("C" & x).EntireRow.Delete End If Next '===================删除汇总end=================================================== '==================================================== '在没有复制之前，先把表头写上
'Wb.Sheets(1).Rows("1:6").Select
Wb.Sheets(1).Rows("1:6").Copy Workbooks(1).ActiveSheet.Cells(1, 1) '写入表头 'Wb.Sheets(1).Range("A1:BQ5").Copy Workbooks(1).ActiveSheet.Cells(1, 1) '写入表头 Num = Num + 1 'Name是为了最后消息提示用的。
max_row = Wb.Sheets(1).Range("b65536").End(xlUp).Row
With Workbooks(1).ActiveSheet .Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4) For G = 1 To 1 '如果需要把隐藏的表也复制，就用sheets.count 'Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1) '带表头
Wb.Sheets(G).Rows("7:5000").Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1) '不带表头
'Wb.Sheets(G).Rows("6:" & .Range("B65536").End(xlUp).Row).Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1) '不带表头 'Wb.Sheets(G).Range("A6:BQ" & max_row).Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1) '不带表头 Next WbN = WbN & Chr(13) & Wb.Name Wb.Close False End With End If
End If MyName = Dir '获取下个文件名 Loop Range("B1").Select
file = MyPath & "\" & "合并后的预算二维表总表" & ".xlsm"
ActiveWorkbook.SaveAs Filename:=file Application.DisplayAlerts = True
Application.ScreenUpdating = True MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
Application.Quit End Sub Sub 生成全部_业绩_一维表() '业绩一维表的表头是三行，数据从第四行开始。
'而预算一维表的表头是四行，数据是从第五行开始的 Dim MyPath, MyName, AWbName Dim Wb As Workbook, WbN As String Dim G As Long Dim Num As Long Dim BOX As String Application.ScreenUpdating = False
Application.DisplayAlerts = False MyPath = ActiveWorkbook.Path '获取当前文件所在的目录 MyName = Dir(MyPath & "\" & "*.xls*") '获取当前目录下的所有包含xls扩展名的文件 AWbName = ActiveWorkbook.Name '当前工作表的名字 Num = 0
'必须要加上这句代码，作用：删除当前表的所有数据，初始化，如果不加，生成的一维总表会带有二维的数据
Cells.Delete Do While MyName <> "" If MyName <> AWbName Then If MyName <> "合并后的业绩二维表总表.xlsm" Then Set Wb = Workbooks.Open(MyPath & "\" & MyName) '========================================================================================
'在没有复制之前，先把表头写上
'Wb.Sheets(1).Rows("1:4").Select
Wb.Sheets(Sheets.Count).Rows("1:3").Copy Workbooks(1).ActiveSheet.Cells(1, 1) '写入表头 Num = Num + 1 'Name是为了最后消息提示用的。
max_row = Wb.Sheets(Sheets.Count).Range("b65536").End(xlUp).Row
With Workbooks(1).ActiveSheet .Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4) For G = Sheets.Count To Sheets.Count '如果需要把隐藏的表也复制，就用sheets.count Wb.Sheets(G).Rows("4:10000").Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1) '不带表头 Next WbN = WbN & Chr(13) & Wb.Name
Wb.Sheets(Sheets.Count).Delete
Wb.Close False End With End If End If MyName = Dir '获取下个文件名
'把用完的最后一张表删除
'Debug.Print Wb.Sheets(Sheets.Count).Name Loop Range("B1").Select
'file = MyPath & "\合并后的业绩一维表总表.xlsm"
'ActiveWorkbook.Save '动态计算毛利率的值
'获取整个表的总行数 count_rows = ActiveSheet.Range("L65536").End(xlUp).Row Debug.Print count_rows
For h = 4 To count_rows '如果H列单元格的值为0 ，则清空此单元格 If Range("H" & h).Value = 0 Then
Range("H" & h).Value = "" End If If Range("E" & h) <> 0 Then
If Range("C" & h) = "$" Then
On Error Resume Next Debug.Print Round((Range("E" & h) - Range("F" & h)) / Range("E" & h), 3)
Range("I" & h) = Round((Range("E" & h) - Range("F" & h)) / Range("E" & h), 3)
Else On Error Resume Next
Debug.Print Round(((Range("E" & h) * Range("L" & h) - Range("F" & h)) / Range("E" & h) * Range("L" & h)), 3)
Range("I" & h) = Round(((Range("E" & h) * Range("L" & h) - Range("F" & h)) / (Range("E" & h) * Range("L" & h))), 3) End If
Else
Range("I" & h) = 0 End If Next file = MyPath & "\合并后的业绩一维表总表.xlsm"
ActiveWorkbook.SaveAs Filename:=file Application.ScreenUpdating = True
Application.DisplayAlerts = True MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
Application.Quit End Sub Sub 生成全部_预算_一维表() '业绩一维表的表头是三行，数据从第四行开始。
'而预算一维表的表头是四行，数据是从第五行开始的 Dim MyPath, MyName, AWbName Dim Wb As Workbook, WbN As String Dim G As Long Dim Num As Long Dim BOX As String Application.ScreenUpdating = False
Application.DisplayAlerts = False MyPath = ActiveWorkbook.Path '获取当前文件所在的目录 MyName = Dir(MyPath & "\" & "*.xls*") '获取当前目录下的所有包含xls扩展名的文件 AWbName = ActiveWorkbook.Name '当前工作表的名字 Num = 0
'必须要加上这句代码，作用：删除当前表的所有数据，初始化，如果不加，生成的一维总表会带有二维的数据
Cells.Delete Do While MyName <> "" If MyName <> AWbName Then
If MyName <> "合并后的预算二维表总表.xlsm" Then Set Wb = Workbooks.Open(MyPath & "\" & MyName) '========================================================================================
'在没有复制之前，先把表头写上
'Wb.Sheets(1).Rows("1:4").Select
Wb.Sheets(Sheets.Count).Rows("1:4").Copy Workbooks(1).ActiveSheet.Cells(1, 1) '写入表头 Num = Num + 1 'Name是为了最后消息提示用的。
max_row = Wb.Sheets(Sheets.Count).Range("b65536").End(xlUp).Row
With Workbooks(1).ActiveSheet .Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4) For G = Sheets.Count To Sheets.Count '如果需要把隐藏的表也复制，就用sheets.count Wb.Sheets(G).Rows("5:10000").Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1) '不带表头 Next '删除用过的中间表。
'Debug.Print Wb.Sheets(Sheets.Count).Name WbN = WbN & Chr(13) & Wb.Name Wb.Close False End With End If
End If MyName = Dir '获取下个文件名 Loop Range("B1").Select
file = MyPath & "\合并后的预算一维表总表.xlsm"
ActiveWorkbook.SaveAs Filename:=file Application.ScreenUpdating = True
Application.DisplayAlerts = True MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
Application.Quit End Sub
