跟王佩丰学习VBA-纯代码（1-8讲）

最新推荐文章于 2023-06-11 18:28:18 发布

这里交给我，你们先走

最新推荐文章于 2023-06-11 18:28:18 发布

阅读量6.6k

点赞数 7

分类专栏： excel vba 学习笔记文章标签： excel vba

本文链接：https://blog.csdn.net/yudong_ma/article/details/112356218

版权

学习笔记同时被 2 个专栏收录

12 篇文章 0 订阅

订阅专栏

excel vba

1 篇文章 0 订阅

订阅专栏

本教程涵盖Excel VBA的基础应用，包括录制宏、条件判断（IF语句）、工作表操作如批量创建、筛选、删除及数据处理。讲解了如何使用VBA进行数据筛选、工作表的复制、删除、移动，以及根据条件填充数据和计算新个税。同时，还涉及到了工作簿中的事件处理，如Change和SelectionChange事件，实现自动化数据处理和更新。

摘要由CSDN通过智能技术生成

@123

跟王佩丰学习VBA-纯代码（1-8讲）

第一讲录制宏

第一讲主要是方法论，介绍了录制宏的办法，初识VBA

选中特定行，更改位置，并进行筛选

在这里插入代码片Sub 宏1()
'
' 宏1 宏
'

'
    Columns("C: E").Select
    Selection. Delete Shift:=xlToLeft
    Columns("G: G").Select
    Selection.Cut
    Columns("B: B").Select
    Selection. Insert Shift:=xlToRight
    Range("E2").Select
    Selection.AutoFilter
    ActiveSheet. Range("$A$1:$H$114").AutoFilter Field:=7, Criteria1:=">200", _
        Operator:=xlAnd
End Sub

开启宏的相对引用，制作工资条

Sub gzt()
Dim i As Integer
Rows("1:1").Select
For i = 1 To 10
    Selection.Copy
    ActiveCell.Offset(2, 0).Rows("1:1").EntireRow.Select
    Selection. Insert Shift:=xlDown
Next
End Sub

改颜色

Sub gys())
Dim i As Integer
For i = 1 To 50
    WithSelection. Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    ActiveCell.Offset(7, 0).Range("A1").Select
Next
End Sub

第二课招募if

利用if进行条件判断，初识for

Sub pd()
Dim i As Integer
For i = 26 To 2 Step -1
    '处理性别的代码
    If Range("e" & i) = "男" Then
        Range("f" & i) = "先生"
    Else
        Range("f" & i) = "女士"
    End If
    
    '处理专业代号
    If Range("b" & i) = "理工" Then
        Range("c" & i) = "LG"
    ElseIf Range("b" & i) = "文科" Then
        Range("c" & i) = "WK"
    Else
        Range("c" & i) = "CJ"
    End If                        
    If Range("d" & i) = "" Then
        Range("D" & i).Select
        Selection.EntireRow.Delete
    End If            
Next
End Sub

新个税计算

Sub gs()
Dim i As Integer
For i = 2 To 12

If Range("c" & i) - 3500 <= 0 Then
    Range("d" & i) = 0
ElseIf Range("c" & i) - 3500 > 0 And Range("c" & i) - 3500 <= 1500 Then
    Range("d" & i) = (Range("c" & i) - 3500) * 0.03
ElseIf Range("c" & i) - 3500 > 1500 And Range("c" & i) - 3500 <= 4500 Then
    Range("d" & i) = (Range("c" & i) - 3500) * 0.1 - 105
ElseIf Range("c" & i) - 3500 > 4500 And Range("c" & i) - 3500 <= 9000 Then
    Range("d" & i) = (Range("c" & i) - 3500) * 0.2 - 555
ElseIf Range("c" & i) - 3500 > 9000 And Range("c" & i) - 3500 <= 35000 Then
    Range("d" & i) = (Range("c" & i) - 3500) * 0.25 - 1005
ElseIf Range("c" & i) - 3500 > 35000 And Range("c" & i) - 3500 <= 55000 Then
    Range("d" & i) = (Range("c" & i) - 3500) * 0.3 - 2755
ElseIf Range("c" & i) - 3500 > 55000 And Range("c" & i) - 3500 <= 80000 Then
    Range("d" & i) = (Range("c" & i) - 3500) * 0.35 - 5505
Else
    Range("d" & i) = (Range("c" & i) - 3500) * 0.45 - 13505
End If

Next
    
End Sub

第三课操作工作表

批量建表

Sub test2()
'建100张表，分别叫1,2,3,4.....
For i = 1 To 100
    Sheets. Add after:=Sheets(Sheets. Count)
    Sheets(Sheets. Count).Name = i
Next

End Sub

取表名，并把表名赋给表1单元格

Sub test()
Dim i As Integer
For i = 2 To Sheets. Count
    Range("a" & i - 1) = Sheets(i).Name
Next
End Sub

根据日报表模板，批量建表，copy方法

在这里插入图片描述

Sub test()
Dim i As Integer

For i = 1 To 31
    Sheet1.Copy after:=Sheets(Sheets. Count)
    Sheets(Sheets.Count).Name = "5月" & i & "日"
    Sheets(Sheets. Count).Range("e5") = "2016-5-" & i
Next
End Sub

多表汇总

Sub test()
Dim i As Integer
For i = 2 To Sheets. Count
    Sheet1.Range("b" & i + 8) = Sheets(i).Range("e5")
    Sheet1.Range("c" & i + 8) = Sheets(i).Range("e6")
    Sheet1.Range("d" & i + 8) = Sheets(i).Range("e44")
Next
End Sub

在这里插入图片描述

第四课操作工作簿

删除工作表

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 = True

End Sub

表格拆分为多个文件

Sub test()
Dim sht As Worksheet
For Each sht In Sheets
    sht.Copy
    ActiveWorkbook. SaveAs Filename:="d:\data\" & sht.Name & ".xlsx"
    ActiveWorkbook.Close
Next
End Sub

制作作业成绩表

Sub test()
Dim i As Integer
Dim sht As Worksheet
For Each sht In Worksheets
    sht.Select
    For i = 100 To 2 Step -1
        '处理性别的代码
        If Range("e" & i) = "男" Then
            Range("f" & i) = "先生"
        Else
            Range("f" & i) = "女士"
        End If
        
        '处理专业代号
        If Range("b" & i) = "理工" Then
            Range("c" & i) = "LG"
        ElseIf Range("b" & i) = "文科" Then
            Range("c" & i) = "WK"
        Else
            Range("c" & i) = "CJ"
        End If         
        '删除空行
        If Range("d" & i) = "" Then
            Range("D" & i).Select
            Selection.EntireRow.Delete
        End If
    Next
    
    '拆分表
    sht.Copy
    ActiveWorkbook.SaveAs Filename:="d:\data\" & sht.Name & ".xlsx"
    ActiveWorkbook.Close
    
Next

End Sub

在这里插入图片描述

第五课操作单元格对象

选取表格的几种方式


Sub test1()
[a10] = 1
End Sub

Sub test2()
Cells(10, 1) = 1
End Sub

Sub test3()
Range("a10") = 1
End Sub

Sub test4()
Range("a1").Offset(10, 0) = 1
End Sub

Sub test5()
Range("b1") = Range("a10").Row
End Sub

Sub test6()
Range("b1") = Range("a10").End(xlUp).Row
End Sub

Sub test7()
Range("a10").EntireRow.Delete
End Sub

用循环拆分表

Sub 用循环拆分()
Dim i, j As Integer

For i = 2 To Sheet1.Range("a65535").End(xlUp).Row
    j = Sheets(Sheet1.Range("d" & i).Value).Range("a65535").End(xlUp).Row + 1
    Sheet1.Range("a" & i).EntireRow. Copy Sheets(Sheet1.Range("d" & i).Value).Range("a" & j)
Next

End Sub

清空结果

Sub 清空结果()
Dim sht As Worksheet
For Each sht In Worksheets
    
    If sht.Name <> "数据" Then sht.Range("a2:f10000").ClearContents

Next


End Sub

用筛选拆分

Sub 用筛选拆分()
Dim i As Integer
Dim sht As Worksheet

i = Sheet1.Range("a65535").End(xlUp).Row
For Each sht In Worksheets
    If sht.Name <> 数据 Then
    
        Sheet1.Range("a1:f" & i).AutoFilter field:=4, Criteria1:="=" & sht.Name
        Sheet1.Range("a1:f" & i).Copy sht.Range("a1")
    
    End If
Next
Sheet1.Range("a1:f" & i).AutoFilter
End Sub

第六课操作单元格对象2

将数据拆分到多表

Sub shaifen()
Dim i As Integer
For i = 2 To Sheets.Count
    Sheet1.Range("a1:f1048").AutoFilter Field:=4, Criteria1:=Sheets(i).Name
    Sheet1.Range("a1:f1048").Copy Sheets(i).Range("a1")
Next
Sheet1.Range("a1:f1048").AutoFilter
End Sub

在这里插入图片描述

建表时避免重名

通过k设定判断机制

Sub xinjianbiao()
Dim sht As Worksheet
Dim k As Integer
For i = 1 To 3
    k = 0
    For Each sht In Sheets
        If sht.Name = Sheet1.Range("a" & i) Then
            k = 1
        End If
    Next
    
    If k = 0 Then
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Sheet1.Range("a" & i)
    End If
Next

根据部门列创建工作表

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 = True '这个地方上课的时候我没改成true，请大家注意一下

irow = Sheet1.Range("a65536").End(xlUp).Row
'拆分表
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

在这里插入图片描述

第七课 VBA事件与典型应用案例

change事件

Sub gys()

Cells.Interior.Pattern = xlNone
Selection.EntireRow.Interior.Color = 65535

End Sub

在工作表中设置selectionchange事件

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Call gys

End Sub

自动筛选

Sub shaixuan()

Range("l1:q10000").ClearContents
Range("A1:F232").AutoFilter Field:=4, Criteria1:=Range("i2")
Range("A1:F232").Copy Range("l1")
Range("A1:F232").AutoFilter

End Sub

在工作表中设置change事件

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Call shaixuan
Application.EnableEvents = True
End Sub

在这里插入图片描述

自动更新

在工作表中设置activate事件

Private Sub Worksheet_Activate()
ActiveWorkbook.RefreshAll
End Sub

自动备份

在工作簿中设置beforesave事件

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

ThisWorkbook.SaveCopyAs "d:\data\" & Format(Now(), "yyyymmddhhmmss") & ".xls"

End Sub

其他事件

在控件中设置click事件

Private Sub CommandButton1_Click()
MsgBox "点我干嘛"
End Sub

第八课在VBA中使用公式

使用countif、CountA和vlookup

Sub tongji()
Dim i, k, l, m As Integer

For i = 2 To Sheets. Count
    k = k + Application. WorksheetFunction. CountA(Sheets(i).Range("a: a")) - 1
    l = l + Application. WorksheetFunction. CountIf(Sheets(i).Range("f: f"), "男")
    m = m + Application. WorksheetFunction. CountIf(Sheets(i).Range("f: f"), "女")
Next
Sheet1.Range("d26") = k
Sheet1.Range("d27") = l
Sheet1.Range("d28") = m
End Sub

Sub chaxun()
On Error Resume Next

Sheet1.Range("d14").ClearContents

For i = 2 To Sheets.Count
    Sheet1.Range("d14") = Application.WorksheetFunction.VLookup(Sheet1.Range("d9"), Sheets(i).Range("a:h"), 5, 0)
    Sheet1.Range("d16") = Application.WorksheetFunction.VLookup(Sheet1.Range("d9"), Sheets(i).Range("a:h"), 6, 0)
    Sheet1.Range("d18") = Application.WorksheetFunction.VLookup(Sheet1.Range("d9"), Sheets(i).Range("a:h"), 3, 0)
    Sheet1.Range("d20") = Application.WorksheetFunction.VLookup(Sheet1.Range("d9"), Sheets(i).Range("a:h"), 8, 0)
    Sheet1.Range("d22") = Sheets(i).Name
    
    If Sheet1.Range("d14") <> "" Then
        Exit For
    End If
Next
End Sub

在这里插入图片描述

拆分数据、isnumberic

Sub chaifenshuju()

Dim sht As Worksheet
Dim k, i, j As Integer
Dim irow As Integer '这个说的是一共多少行
Dim l

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

If IsNumeric(l) = False Or l < 1 Then
    Exit Sub
End If

l = Val(l)

'删除无意义的表
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 = True '这个地方上课的时候我没改成true，请大家注意一下


irow = Sheet1.Range("a65536").End(xlUp).Row
'拆分表
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

VBA函数

Sub test()

Sheet1.Range("b2") = Left(Sheet1.Range("a2"), InStr(Sheet1.Range("a2"), "@") - 1)


End Sub

Sub tiqu()

On Error Resume Next
For i = 2 To Sheet2.Range("a65536").End(xlUp).Row

    Sheet2.Range("b" & i) = Split(Sheet2.Range("a" & i), "-")(2) & "年 第" & Split(Sheet2.Range("a" & i), "-")(3) & "周"

Next
End Sub