首页 > 其他分享 >关于VBA中，activesheet用法的一些思考

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

时间：2022-11-02 10:58:15浏览次数：52  
标签：VBA End max activesheet 用法 Range Sheets xlUp row

前二天，给财务部做了个数据采集的工具，因为财务现在用的是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,End,max,activesheet,用法,Range,Sheets,xlUp,row
From： https://www.cnblogs.com/lyt263/p/16850274.html

相关文章

  • $.each()的几种常见用法整理
    参考声明:https://blog.csdn.net/zhangxiwen_/article/details/89021499参考声明:$.each()遍历一维数组:vararr1=["aaa","bbb","ccc"];$.each(arr1,function......
  • html 和css的一些基础用法
    HTML多媒体嵌入，如图片，音视频：＜imgsrc="图片路径"alt="未加载出来时显示的图片描述＂＞图片source推荐放在网页同路径下images文件夹中，有利于Google搜索引擎优化SEO／索引HTML......
  • const_cast与用法总结
    去掉const属性。（仅针对于指针和引用）   ......
  • mybatis-plus 用法
    本文主要介绍mybatis-plus这款插件，针对springboot用户。包括引入，配置，使用，以及扩展等常用的方面做一个汇总整理，尽量包含大家常用的场景内容。   原文：https://ju......
  • sed基本用法与正则表达式
    sed工作原理sed即StreamEditor，和vi不同，sed是行编辑器。Sed是从文件或管道中读取一行，处理一行，输出一行;再读取一行，再处理一行，再输出一行，直到最后一行。每当处理一行时，把......
  • CyclicBarrier、CountDownLatch、Semaphore的用法
    CyclicBarrier、CountDownLatch、Semaphore的用法CountDownLatch（线程计数器）CountDownLatch类位于java.util.concurrent包下，利用它可以实现类似计数器的功能。比如有......
  • yml/yaml--文件格式/配置文件--用法/写法
    原文网址：yml/yaml--文件格式/配置文件--用法/写法_IT利刃出鞘的博客-CSDN博客简介说明     YAML 是一种简洁的非标记语言，文件名后缀为.yml，java中经常用它描述......
  • Excel VBA的基础知识点，初学者必须掌握
    我们在前面已经说到录制宏和资源工程管理器，也许你已经初步知道如何去录制宏，但是你还是不能快速的理解他们，因为你对VBA的基础概念知识还是很欠缺的。我们今天要和你说的是几......
  • C++ 中的 auto的用法
    auto的原理就是根据后面的值，来自己推测前面的类型是什么。auto的作用就是为了简化变量初始化，如果这个变量有一个很长很长的初始化类型，就可以用auto代替。1.用auto声明的......
  • 委托+方法+lambda优雅用法
    usingSystem;usingSystem.Collections.Generic;usingSystem.Linq;usingSystem.Text;usingSystem.Threading.Tasks;namespaceConsoleApp.DDUP{publiccl......

赞助商

阅读排行

网站主页关于我们联系我们网站地图

本网站内容转载自其他媒体，侵权联系[admin##ips99.com]。

Copyright © 2020-2023 IPS99 版权所有 IPS99