关于VBA中，activesheet用法的一些思考
前二天，给财务部做了个数据采集的工具，因为财务现在用的是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
