关于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

关于VBA中，activesheet用法的一些思考的更多相关文章

在VBA中使用Windows API
VBA是一种强大的编程语言,可用于自定义Microsoft Office解决方案.通过使用VBA处理一个或多个Office应用程序对象模型,可以容易地修改Office应用程序的功能或者能够使两个或多个 ...
VBA中四种自动运行的宏以及模块的含义
在Excel的“标准模块”中可以创建4种自动运行的宏,它们分别是Auto_Open(打开工作簿时自动运行), Auto_Close, Auto_Activate, Auto_Deactivate. ...
VBA中find的一些使用方法
用excel处理数据的时候,无论是使用VBA还是函数,查找和引用都是两大主要的工作,VBA中的find系列的方法(find.findnext.Range.FindPrevious)返回range对象, ...
【LeetCode刷题】SQL-Second Highest Salary 及扩展以及Oracle中的用法
转载于:https://www.cnblogs.com/contixue/p/7057025.html Write a SQL query to get the second highest sala ...
[转载]C#中MessageBox.Show用法以及VB.NET中MsgBox用法
一.C#中MessageBox.Show用法 MessageBox.Show (String) 显示具有指定文本的消息框. 由 .NET Compact Framework 支持. MessageBo ...
ORACLE 中ROWNUM用法总结(转)
ORACLE 中ROWNUM用法总结! 对于 Oracle 的 rownum 问题,很多资料都说不支持>,>=,=,between...and,只能用以上符号(<.<=.!=) ...
VB类模块中属性的参数——VBA中Range对象的Value属性和Value2属性的一点区别
在VB中,属性是可以有参数的,而VBA中属性使用参数非常常见.比如最常用的:Worksheet.Range("A1:A10") VB的语法,使用参数的不一定是方法,也有可能是属性 ...
AngularJS select中ngOptions用法详解
AngularJS select中ngOptions用法详解一.用法 ngOption针对不同类型的数据源有不同的用法,主要体现在数组和对象上. 数组: label for value in a ...
在VBA中新建工作簿
用程序计算数据,得到不同公司.不同项目的数据结果,最终还要将每个公司的数据结果放在各自的单独文件中.这就需要在vba中新建.保存excel文件.掌握几个东西就能很熟练了:1.要想保存在当前目录下,需要 ...
在VBA中调用excel函数
以前不太会用VBA时,都是在excel中使用函数来计算一些数据.毕竟函数不如代码,效率比较低.所以,就学着怎么在VBA中引用Excel函数.平时我用得比较多的函数就是countif和sumif函数.1 ...

随机推荐

Spark基本知识
Spark基本知识 Spark 是一种基于内存的快速.通用.可扩展的大数据分析计算引擎. spark与hadoop的区别 Hadoop Hadoop 是由 java 语言编写的,在分布式服务器集群上存 ...
Element基本组件
Element按钮组件: <el-row> <el-button>默认按钮</el-button> <el-button type="primary ...
python字符串的一些操作
# 1.变量的多次赋值 print('1.变量的多次赋值') name = '小明' # 没有意义的 name = '小刚' # 对前面创建的变量名称进行覆盖 # 删除原来的数据,写入新的数据 pri ...
Java线程未捕获异常处理 UncaughtExceptionHandler
当一个线程在执行过程中抛出了异常,并且没有进行try..catch,那么这个线程就会终止运行.在Thread类中,提供了两个可以设置线程未捕获异常的全局处理器,我们可以在处理器里做一些工作,例如将异常 ...
WinDBG详解进程初始化dll是如何加载的
一:背景 1.讲故事有朋友咨询个问题,他每次在调试 WinDbg 的时候,进程初始化断点之前都会有一些 dll 加载到进程中,比如下面这样: Microsoft (R) Windows Debugg ...
WPF之BackgroundWorker
BackgroundWorker类允许您在单独的线程上执行某个可能导致用户界面(UI)停止响应的耗时操作,下面来介绍一下这个线程类BackgroundWorker,大家可以结合这位大佬的这篇文章,说的 ...
RocketMQ 在物流行业的应用与运维
本文作者:丁威 - 中通快递资深架构师,<RocketMQ技术内幕>作者,Apache RocketMQ社区首席布道师,公众号「中间件兴趣圈」维护者. 01 物流行业的业务特点物流行业有 ...
Vue3笔记（二）了解组合式API的应用与方法
一.组合式API(Composition API)的介绍官方文档: https://v3.cn.vuejs.org/guide/composition-api-introduction.html 组 ...
原来用 MySQL 也可以做全文检索
我是风筝,公众号「古时的风筝」,专注于 Java技术及周边生态. 文章会收录在 JavaNewBee 中,更有 Java 后端知识图谱,从小白到大牛要走的路都在里面. 有朋友聊到他们的系统中要接入全 ...
ArcObjects SDK开发 001 ArcObjects SDK 简介
1.什么是ArcObjects SDK 在网上搜索什么是ArcObjects,会搜到如下的定义. 这个定义比较准确,也比较容易理解. 2.什么是ArcEngine 在网上搜索ArcEngine,一般会 ...

关于VBA中，activesheet用法的一些思考

关于VBA中，activesheet用法的一些思考的更多相关文章

随机推荐

热门专题