EXCEL | VBA实例操作

作者: 三生石蓝 | 来源:发表于2019-01-14 16:59 被阅读0次

将工作簿中的所有工作表单独保存，原表仍然存在

1.原工作簿：

原工作簿

2.效果显示：

单独工作表

3.VBA代码：

Sub chaifen()

'定义变量sht为工作表
Dim sht As Worksheet
'在所有工作表中遍历一次
For Each sht In Sheets
'工作表复制
    sht.Copy
'目前活动的工作表另存为，注意路径的写法
    ActiveWorkbook.SaveAs Filename:="D:\C 文件\excel\VBA\day03\CHAIFEN\" & sht.Name & ".xlsx"
'目前活动的工作表关闭
    ActiveWorkbook.Close
Next
End Sub

4.知识点：
thisworkbook：指当前VBA代码所处的 workbook
activeworkbook:指当前活跃的workbook
相同点：如果VBA代码只对本身工作薄进行操作，则两者相同；
不同点：如果VBA代码新建或打开了其他工作薄，则往往新建或刚打开的是activeworkbook，可以通过"工作薄名.active"方法激活指定对象。

保留工作薄中不想删除的工作表，其他全部删除

1.原工作薄

绝不能删除1.png

2.删除后

绝不能删除2.png

3.VBA代码

Sub test()
'删除其他表，保留 绝不能删除 表
Dim sht As Worksheet

Application.DisplayAlerts = False

For Each sht In Sheets
'如果工作表名不等于“决不能删除”
    If sht.Name <> "绝不能删除" Then
    '将工作表删除
        sht.Delete
    End If
Next

Application.DisplayAlerts = False

End Sub

4.知识点：
worksheet:单个工作表
worksheets:指定工作薄中所有工作表的集合
Application.DisplayAlerts：如果宏运行时Excel显示特定的警告和信息，则该值为True。如果不想在宏运行时被无穷无尽的提示和警告消息困扰，则将该属性设置为False。

利用空白工作薄控制创建新的工作薄并填写内容

1.VBA代码

Sub chuangjian()
'新建工作薄
Workbooks.Add
'活动工作薄工作表1单元格a1填写内容“这是我自动创建出来的”
ActiveWorkbook.Sheets(1).Range("a1") = "这是我自动创建出来的"
'活动工作薄另存为到指定的文件路径
ActiveWorkbook.SaveAs Filename:="D:\C 文件\excel\VBA\day03\123.xlsx"
End Sub

2.运行效果

123.png

123内容.png

3.知识点：
Workbooks:对象是Microsoft Excel应用程序中当前打开的所有Workbook对象的集合，有Close、Add、Open等方法
Workbook:对象是一个Microsoft Excel工作薄，有name、path等属性，有SaveAs等方法，有Open、Activate等事件
Workbooks.Add:新建工作薄，新建的工作薄将成为活动工作薄

利用空白工作薄控制已有的工作薄并填写内容

1.空白的工作表1

空白的工作表1

2.VBA代码

Sub test()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
'工作薄打开指定路径下的1.xlsx
Workbooks.Open Filename:="D:\C 文件\excel\VBA\day03\1.xlsx"
'活动工作薄工作表1单元格a1填写"又又到此一游"
ActiveWorkbook.Sheets(1).Range("a1") = "又又到此一游"
'活动工作薄保存
ActiveWorkbook.Save
'活动工作薄关闭
ActiveWorkbook.Close

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

3.含内容的工作表1

又又到此一游1.png

4.知识点：
Application.ScreenUpdating:在Excel的工作表里面数据发生变化后，False禁止实时刷新，True为默认值表示实时更新数据

按部门名称来筛选数据

1.筛选数据

筛选数据

2.VBA代码

Sub chaifen()

    Sheet1.Range("a1:F32").AutoFilter Field:=4, Criteria1:="一车间"

End Sub

3.筛选一车间

筛选一车间

将数据工作表取消筛选状态

1.筛选状态

筛选状态

2.VBA代码

Sub qxshaixuan()
    
    Sheet1.Range("a1:F32").AutoFilter

End Sub

3.取消筛选

取消筛选

将工作表数据按照部门拆分到部门名称所对应的工作表中-No.01

【注意事项】：分表已经提前做好，需要拷贝数据到分表中
1.如下所示：

工作表-数据

按照数据表部门，分别实现以部门名称建立的新表，然后将数据表中部门名称单元格所在行复制到新表中。

2.代码如下：

Sub chaifen1()

'实现功能：将数据表中Range("d" & i)单元格对应的行数据拆分到新表Range("d" & i).value名称的表中

    '定义整型数据i,k,j
    Dim i,k,j As Integer
           
    '遍历第二个工作表到最后一个工作表
    For j = 2 To Sheets.Count
    
        '将工作表数据中的抬头拷贝到其他工作表中去
        Sheet1.Range("a1").Resize(1, 6).Copy Sheets(j).Range("a1")
    
        '遍历数据表中第二行到最后一行数据
        For i = 2 To Sheets(1).Range("a65536").End(xlUp).Row
        
            '假如数据表单元格("d" & i)单元格对应的值等于表二的名称
            If Sheet1.Range("d" & i).Value = Sheets(j).Name Then
            
                '计算表二目前状态下已有多少行数据
                k = Sheets(j).Range("a65536").End(xlUp).Row
                
                '将数据表中Range("d" & i)单元格所在整行数据拷贝到数据表中已有行数的下一行
                Sheet1.Range("d" & i).EntireRow.Copy Sheets(j).Range("a" & k + 1)  
            End If
        Next
    Next 
End Sub

3.得到效果：

工作表-二车间

工作表-一车间

在分表中出现小数点，暂时还未知原因！

4.知识点：
{1}、在保存含有VBA代码的文件时，在警告提示中选择否，保存格式为xlsm，即可保存成功
{2}、Sheets.Count:获取本工作薄中工作表的总数
{3}、Sheets(Sheets.Count):调用排在最后一位的工作表
{4}、Sheets(Sheets.Count).Name:获取最后一个工作表的名称

将工作表数据按照部门拆分到部门名称所对应的工作表中-No.02

【注意事项】：分表已经提前做好，需要拷贝数据到分表中
【使用方法】：利用excel筛选功能提高效率
1.工作簿表们

工作簿表们

2.VBA代码

Sub shaifen()
'定义整型变量i
Dim i As Integer
'从第二张工作表开始遍历
For i = 2 To Sheets.Count
'根据工作表名称来筛选数据工作表
    Sheet1.Range("a1:F32").AutoFilter Field:=4, Criteria1:=Sheets(i).Name
'将筛选后的数据工作表复制到第i张工作表的a1单元格
    Sheet1.Range("a1:F32").Copy Sheets(i).Range("a1")
Next
'取消数据工作表的筛选
    Sheet1.Range("a1:F32").AutoFilter
End Sub

3.执行筛选复制程序后

财务部1.png

二车间1.png

技改办1.png

经理室1.png

人力资源部1.png

销售1部1.png

销售2部1.png

一车间1.png

4.知识点：
Sheets(i).Name:第i张工作表的名称

将工作表数据按照部门拆分到部门名称所对应的工作表中-No.03

【注意事项】：分表未提前做好，需要拷贝数据到分表中
【使用方法】：判断建表结合筛选功能提高拆分表效率
1.数据工作表

20190117-数据工作表

2.VBA代码

Sub chaifenshuju()
'定义工作表变量sht
Dim sht As Worksheet
'定义整型变量k,i,j
Dim k, i, j As Integer
Dim irow As Integer '此处定义一个一共多少行的整数值

irow = Sheet1.Range("a65536").End(xlUp).Row

'1此处是建立新工作表的代码
'此处为一个标准遍历写法，需要记住
For i = 2 To irow
'将标记值复位，便于创建未重名新工作表
    k = 0

    For Each sht In Sheets
        
        If sht.Name = Sheet1.Range("d" & i) Then
        
            k = 1
        
        End If
    
    Next
    
    If k = 0 Then
    '按部门名称来创建新工作表
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Sheet1.Range("d" & i)
        
    End If
    
Next

'此处是将数据表中的数据按部门进行拷贝到对应部门的工作表中

For j = 2 To Sheets.Count

    Sheet1.Range("a1:f" & irow).AutoFilter Field:=4, Criteria1:=Sheets(j).Name
    Sheet1.Range("a1:f" & irow).Copy Sheets(j).Range("a1")

Next
    '数据工作表取消或者选中筛选状态
    Sheet1.Range("a1:f" & irow).AutoFilter

End Sub

3.拆分后效果

20190117-财务部.png

20190117-二车间.png

20190117-技改办.png

20190117-经理室.png

20190117-人力资源部.png

20190117-销售1部.png

20190117-销售2部.png

20190117-一车间.png

针对MsgBox以及InputBox的测试

1.测试代码

Sub test()

    MsgBox "你好！"

End Sub

【效果展示】

20190117-你好

2.测试代码1

Sub test1()

    InputBox "你几岁了？"

End Sub

【效果展示】

20190117-你几岁了.png

3.测试代码2

Sub test2()

    Dim i As Integer
    
    i = InputBox("你几岁了？")
    
    Sheet1.Range("A1") = i

End Sub

【效果展示】

20190117-输入5后变化.png

20190117-3变成5.png

4.测试代码3

Sub test3()

    Dim i As Integer
    
    i = InputBox("你几岁了？")
    
    MsgBox "哦，原来你6岁啦"

End Sub

【效果展示】

20190117-输入7.png

5.测试代码4

Sub test4()

    Dim i As Integer
    
    i = InputBox("你几岁了？")
    
    MsgBox "哦，原来你" & i & "岁啦"

End Sub

【效果展示】

20190117-输入10.png

20190117-与输入10一致.png

6.测试代码5

Sub test5()

    Range("A1").Select

End Sub

【效果展示】

20190117-A1选中.png

7.测试代码6

Sub test6()

    Cells(4, 1).Select

End Sub

【效果展示】

20190117-A4选中.png

将工作表数据按照部门拆分到部门名称所对应的工作表中-No.04

【注意事项】：分表未提前做好，需要拷贝数据到分表中
【使用方法】：在NO.03的基础上再升级成最终版本
1.使用控件

使用控件

2.VBA代码

Sub chaifenshuju()

Dim sht As Worksheet
Dim k, i, j As Integer
Dim irow As Integer '此处定义一个一共多少行的整数值
Dim l As Integer

l = InputBox("请输入你要按哪列分")


'创建新表之前，删除除数据工作表之外的其他工作表
'消除提示
Application.DisplayAlerts = False
If Sheets.Count > 1 Then

    For Each sht1 In Sheets
    
        If sht1.Name <> "数据" Then
        
            sht1.Delete
        
        End If
    
    Next

End If

'消除提示
Application.DisplayAlerts = False


irow = Sheet1.Range("a65536").End(xlUp).Row
'1此处是建立新工作表的代码
'此处为一个标准遍历写法，需要记住
For i = 2 To irow

    k = 0

    For Each sht In Sheets
        
        If sht.Name = Sheet1.Cells(i, l) Then
        
            k = 1
        
        End If
    
    Next
    
    If k = 0 Then
    
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Sheet1.Cells(i, l)
        
    End If
    
Next

'此处是将数据表中的数据按部门进行拷贝到对应部门的工作表中

For j = 2 To Sheets.Count

    Sheet1.Range("a1:f" & irow).AutoFilter Field:=l, Criteria1:=Sheets(j).Name
    Sheet1.Range("a1:f" & irow).Copy Sheets(j).Range("a1")

Next
    '数据取消或者选中筛选状态
    Sheet1.Range("a1:f" & irow).AutoFilter
    
    Sheet1.Select
    
    MsgBox "已经执行完毕！"

End Sub

3.执行效果

20190118-按第四列来分

20190118-按第五列来分

4.功能：可以按照列数来进行拆分工作表

按工作表1中单元格内容进行创建新工作表

1.Sheet1

Sheet1.png

2.VBA代码-No.01

Sub xinjianbiao01()

    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = Sheet1.Range("a1")

End Sub

3.VBA代码-No.02

Sub xinjianbiao02()

    Sheets.Add(after:=Sheets(Sheets.Count)).Name = Sheet1.Range("a2")

End Sub

4.执行代码后

1月2月.png

5.知识点：
Sheets.Add after:=Sheets(Sheets.Count):在最后一张工作表后添加新工作表

按工作表1中单个单元格内容进行创建新工作表

1.工作薄

Sheet1.png

2.VBA代码
Sub xinjianbiao()

'此处k被定义为整数，默认初始值为0，可以看做是一个开关，判断新表是否能够建立
'此处是针对工作表1单元格a1进行创建新表

Dim sht As Worksheet
Dim k As Integer

'遍历目前已经存在的工作表
For Each sht In Sheets
'如果存在工作表名与制定单元格值相同，则给k赋值1
If sht.Name = Sheet1.Range("a1") Then

    k = 1

End If

'如果k值为0，则说明存在工作表名与制定单元格值没有相同

If k = 0 Then

Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Sheet1.Range("a1")

End If

End Sub
3.执行代码后

1月2月.png

4.知识点：
此处设置整数变量k作为标记值，来判断同工作薄中工作表是否有重复名称，如果没有则新建，如果有则不会另外新建

按工作表1中多个单元格内容进行创建新工作表

1.工作表1

工作表123月.png

2.VBA代码

Sub xinjianbiao1()

'此处k被定义为整数，默认初始值为0，可以看做是一个开关，判断新表是否能够建立
'此处是针对工作表1单元格a1进行创建新表，如果要扩展到a2、a3的话，就需要对a1创建新表的内容循环三次，并稍作修改
'定义工作表变量sht
    Dim sht As Worksheet
'定义整型变量k
    Dim k As Integer    
For i = 1 To 3

    '【血泪提醒】记得要恢复标记值k=0,不然一直为1状态，就无法建立新工作表
    k = 0
    
    '遍历目前已经存在的工作表
    For Each sht In Sheets
        '如果存在工作表名与制定单元格值相同，则给k赋值1
        If sht.Name = Sheet1.Range("a" & i) Then
            k = 1
        End If
    Next
    
    '如果k值为0，则说明存在工作表名与指定单元格值没有相同
    
    If k = 0 Then  
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Sheet1.Range("a" & i) 
    End If  
Next
End Sub

3.1月2月3月

1月2月3月.png

将分工作表内容合并到数据工作表中

【提醒】前提已经创建好数据工作表
1.分工作表

20190117-财务部.png

20190117-二车间.png

20190117-技改办.png

20190117-经理室.png

2.VBA代码（有待优化）

Sub hebingfenbiao()

'整型变量irow为分工作表的总行数，yrow为数据工作表总行数
Dim irow, yrow As Integer

'定义工作表变量sht
Dim sht As Worksheet

For Each sht In Sheets

    irow = sht.Range("a65536").End(xlUp).Row
    yrow = Sheets("数据").Range("a65536").End(xlUp).Row

    If sht.Name <> "数据" Then
                
        sht.Range("a1:f" & irow).Copy Sheets("数据").Range("a" & yrow + 1)
    
    End If

Next

'数据工作表A1单元格所在整行删除
Sheets("数据").Range("A1").EntireRow.Delete

'最后数据工作表被选中
Sheets("数据").Select

'提示操作已经执行完毕！
MsgBox "已经执行完毕！！！"

End Sub

3.合并后效果

20190122 合并分表到数据工作表

录制宏1，对某一单元格字体的大小进行修改

1.原单元格

原单元格大小

2.VBA代码（此代码是录制的）

Sub 宏1()

    With Selection.Font
        .Name = "宋体"
        .Size = 18
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
End Sub

3.执行代码后

执行程序后单元格大小

4.对录制宏代码进行修改

Sub test1()

    Sheet2.Range("A1").Font.Size = 18

End Sub

5.执行后效果

A1字体为18

对With的应用

1.未使用With的代码

Sub test()

    Sheet2.Range("A1") = 6
    Sheet2.Range("A4") = 12
    Sheet2.Range("A5") = 8
    Sheet2.Range("A7") = 10

End Sub

2.使用With的代码

Sub testxiugai()

    With Sheet2
    
        .Range("A1") = 6
        .Range("A4") = 12
        .Range("A5") = 8
        .Range("A7") = 10
    
    End With

End Sub

3.执行后的效果一样

With代码执行后

选中工作表中某单元格，则单元格所在整行标记某颜色

手动模式下的整行变色

1.手动模式下整行变色

手动模式下整行变色

2.VBA代码
【代码位置】代码在模块2中

模块2中的代码

Sub ChangeColor()
    '所有单元格背景色=无填充颜色
    Cells.Interior.Pattern = xlNone
    '选择单元格或者多个单元格（选区）所在整行背景颜色填充为黄色
    Selection.EntireRow.Interior.Color = 65535
     '选择单元格或者多个单元格（选区）所在整列背景颜色填充为黄色
    'Selection.EntireColumn.Interior.Color = 65535
End Sub

3.【弊端】在每次点击其他单元格或区域后，必须要点击宏，选择ChangeColor宏执行后才会有效果，不会自动。

自动模式下的整行变色

1.自动模式下的整行变色

自动模式下整行变色

2.VBA代码
【代码位置】代码在Sheet1

代码在Sheet1中

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    '工作表选区发生变化，此sub是自动执行，不需要每次点击并选择宏
    '此处是事件，如果发生了某事，则会自动执行代码
    
    Cells.Interior.Pattern = xlNone
    Selection.EntireRow.Interior.Color = 65535      
End Sub

EXCEL | VBA实例操作

将工作簿中的所有工作表单独保存，原表仍然存在

保留工作薄中不想删除的工作表，其他全部删除

利用空白工作薄控制创建新的工作薄并填写内容

利用空白工作薄控制已有的工作薄并填写内容

按部门名称来筛选数据

将数据工作表取消筛选状态

将工作表数据按照部门拆分到部门名称所对应的工作表中-No.01

将工作表数据按照部门拆分到部门名称所对应的工作表中-No.02

将工作表数据按照部门拆分到部门名称所对应的工作表中-No.03

针对MsgBox以及InputBox的测试

将工作表数据按照部门拆分到部门名称所对应的工作表中-No.04

按工作表1中单元格内容进行创建新工作表

按工作表1中单个单元格内容进行创建新工作表

按工作表1中多个单元格内容进行创建新工作表

将分工作表内容合并到数据工作表中

录制宏1，对某一单元格字体的大小进行修改

对With的应用

选中工作表中某单元格，则单元格所在整行标记某颜色

手动模式下的整行变色

自动模式下的整行变色

3.【好处】每当单元格点击发生变化后，触发事件，自动执行事件中包含的代码，不用再去点击宏啦！！！

按工作表1中单元格内容进行创建新工作表

相关文章

网友评论

延伸阅读

深度阅读

栏目导航

热点阅读

excel

程序员