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

@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

第九课 自定义函数和带参数的过程

第十课 使用DIR函数多文件合并

第十一课 使用数组

第十二课 使用ActiveX控件

第十课 使用DIR函数多文件合并

第十一课 使用数组

第十二课 使用ActiveX控件

第十三课 窗体与控件

第十四课 VBA中的用户信息交互

第十五课 使用ADO操作外部数据

第十六课 图形、图片、与表单控件

第十七课 触“类”旁通2：类模块

第十八课 字典与用户界面设计

第十九课 Excel+Access系统开发