excel vba学习

视频地址:https://www.bilibili.com/video/BV1gr4y137WY?p=2&vd_source=e90914683379d45ef4287d44b4e7363a
视频作者:老吴
前提准备:

image.png

变量:
image.png

变量数据类型:
image.png

对象:
image.png

对象的表达方法:
image.png

属性:
image.png

方法:
image.png

IF语句:
image.png

image.png

Sub test()
    Dim n1%, n2%
    n1 = 1
    n2 = 3
    If n1 < n2 Then
     MsgBox "n1小于n2"
    End If
End Sub
image.png
Sub test()
    Dim n As Byte
    n = InputBox("请输入成绩")
    If n > 60 And n < 100 Then
        MsgBox "成绩合格"
    ElseIf n < 60 And n > 0 Then
        MsgBox "成绩不合格"
    End If
End Sub
image.png
Sub test()
    If Cells(1, 1) > 150 Then
        Cells(1, 2) = "高级"
    ElseIf Cells(1, 1) > 100 Then
        Cells(1, 2) = "中级"
    Else
        Cells(1, 2) = "低级"
    End If
End Sub

FOR循环:


image.png

image.png

END获取数据边界:


image.png

image.png
Sub test()
    MsgBox Range("a1").End(xlDown).Row
    MsgBox Range("a1").End(xlToRight).Column
End Sub

ROW和ROWS的区别:


image.png
Sub test()
    MsgBox Rows.Count
    MsgBox Columns.Count
End Sub
image.png

usedrange:


image.png

image.png
Sub test()
    MsgBox ActiveSheet.UsedRange.Rows.Count
    MsgBox ActiveSheet.UsedRange.Columns.Count
End Sub

currentregion:


image.png

image.png
Sub test()
    Dim rowsCount%, columnsCount%, i%, j%
    rowsCount = Range("a1").CurrentRegion.Rows.Count
    columnsCount = Range("a1").CurrentRegion.columns.Count
    For i = 1 To rowsCount
        For j = 2 To columnsCount Step 2
            If Cells(i, j) < 60 Then
                Cells(i, j).Interior.ColorIndex = 3
            End If
        Next
    Next
End Sub
image.png

image.png
Sub test()
    Dim ws As Worksheet, i%
    For Each ws In Worksheets
        i = i + 1
        ws.Name = i
    Next
End Sub
image.png

image.png

image.png
Sub test()
    Range("a2").Resize(2, 3).Select
End Sub
image.png
Sub test()
    Dim allRangeB As Range, rng As Range
    Set allRangeB = Range("b1", Range("b1").End(xlDown))
    For Each rng In allRangeB
        If rng > 60 Then
            rng.Offset(0, -1).Resize(1, 4).Interior.ColorIndex = 3
        End If
    Next
End Sub
image.png

image.png
Sub test()
    Dim rngs As Range, tempRange As Range, locationRange As Range, copyRange As Range
    Set rngs = Range("b1", Range("b1").End(xlDown))
    For Each tempRange In rngs
        If tempRange.Value = "牛肉" Then
            n = n + 1
            If n <= 3 Then
                Set locationRange = Cells(Rows.Count, "d").End(xlUp).Offset(1, 0)
                Set copyRange = tempRange.Offset(0, -1).Resize(1, 2)
                copyRange.Copy locationRange
            Else
                Exit For
            End If
        End If
    Next
End Sub
image.png

image.png
Sub test()
    Dim answer%
    Do
        answer = InputBox("please write down the right answer")
        If answer = 7 Then
            MsgBox "the answer is wrong"
        Else
            MsgBox "the answer is right"
        End If
    Loop
End Sub
image.png

image.png

image.png
Sub test()
    Dim answer As Date
    On Error Resume Next
        Do
        answer = InputBox("please write down the right answer")
        If Err.Number <> 0 Then
            GoTo 100
        End If
        If answer = [a1] Then
            MsgBox "the answer is right"
            GoTo 101
        Else
            MsgBox "the answer is wrong"
        End If
100:
        Err.Clear
    Loop
101:
    Range("b1") = "jump out"
End Sub
image.png

image.png
Sub test()
    Dim countNum As Byte, rowsCount As Byte
    rowsCount = Cells(Rows.Count, 1).End(xlUp).Row
    Do While countNum <> 3
        n = n + 1
        If n > rowsCount Then
            countNum = 3
        End If
        If Cells(n, "b") = 100 Then
            Cells(n, "b").Interior.ColorIndex = 3
            countNum = countNum + 1
        End If
    Loop
End Sub
image.png
Sub test()
    Dim countNum As Byte, rowsCount As Byte
    rowsCount = Cells(Rows.Count, 1).End(xlUp).Row
    Do Until countNum = 3
        n = n + 1
        If n > rowsCount Then
            countNum = 3
        End If
        If Cells(n, "b") = 100 Then
            Cells(n, "b").Interior.ColorIndex = 3
            countNum = countNum + 1
        End If
    Loop
End Sub

vba使用工作表函数:


image.png
Sub test()
    [d2] = Application.WorksheetFunction.AverageIf([b:b], "nv", [c:c])
    [d1] = WorksheetFunction.CountIfs([b:b], "nv", [c:c], ">60")
End Sub

vba随机函数:


image.png

排序:


image.png

image.png
Sub test()
    Dim cr As Range
    Set cr = Range("a1").currentRegion
    cr.Sort Range("b1"), xlAscending, Range("c1"), , xlDescending, Header:=xlYes
End Sub

find查询:


image.png

image.png

image.png
Sub test()
    [d1] = Range("a:a").Find("tianqi", , xlValues, xlWhole, , xlNext).Address(0, 0)
End Sub

findnext查询:


image.png

image.png
Sub test()
    Dim rng As Range
    Set rng = Range("a:A").Find("zhangsan")
    MsgBox Range("a:A").FindNext(rng).Row
End Sub

筛选:


image.png

image.png
Sub test()
    Range("a1").AutoFilter 2, ">2", xlAnd, "<800"
End Sub

拆分工作簿:


image.png
Sub test()
    Dim wb As Workbook, w1 As Workbook
    Set w1 = ThisWorkbook
    Set wb = Workbooks.Add
    w1.Sheets(1).Range("a1:a9").Copy wb.Sheets(1).Range("a1")
    wb.SaveAs ThisWorkbook.Path & "/" & "123.xls"
End Sub

UNION并集:


image.png
Sub test()
    Dim rng As Range
    Set rng = Union(Range("a2"), Range("c2"))
    rng.Select
End Sub

交集:


image.png

image.png
Sub test()
    Dim rng As Range
    Set rng = Intersect(Range("a1").Resize(4, 4), Range("b1").Resize(7, 2))
    rng.Select
End Sub

定位:


image.png

image.png

image.png
Sub test()
    Dim rng As Range, ss As Range
    Set rng = Range("a1").CurrentRegion.SpecialCells(xlCellTypeBlanks)
    For Each ss In rng
        ss.Value = "test value"
    Next
End Sub

AutoFill自动填充:


image.png

image.png

image.png
Sub test()
    Range("e2").AutoFill Range("e2:e8")
End Sub

replace替换:


image.png

image.png
Sub test()
    Range("a1").CurrentRegion.Replace what:="test value", replacement:="new valuesss "
End Sub

with语句:


image.png

image.png
Sub test()
    With ThisWorkbook.Sheets(1)
        .Range("e1") = 1
        .Range("e2") = 2
        .Range("e3") = 3
    End With
End Sub

DIR函数:


image.png

image.png
Sub test()
    Dim fileName$
    fileName = Dir("/Users/luowei/Downloads/")
    Do
        n = n + 1
        Cells(n, "f").Value = fileName
        fileName = Dir
    Loop Until fileName = ""
End Sub

超链接:


image.png

image.png

image.png

image.png
Sub test()
    Sheet1.Hyperlinks.Add Range("e1"), "/Users/luowei/Downloads/计算机组成原理.pdf", "a1", "ti shi", "xianshi"
End Sub

合并单元格:


image.png

instr函数:


image.png

image.png
Sub test()
    MsgBox InStr(Range("f4"), ".")
End Sub

like运算符:


image.png

image.png

image.png
Sub test()
    MsgBox "12" Like "?2"
End Sub

name语句:


image.png

image.png
Sub test()
    Name "/Users/luowei/Downloads/tt.xlsx" As "/Users/luowei/Downloads/test.xlsx"
End Sub

不同单元格填充不同颜色:


image.png

批量移动文件:


image.png

mkdir:
image.png
Sub test()
    MkDir ThisWorkbook.Path & "/tset"
End Sub

数组写入和读取


image.png
Sub test()
'    arr = Array(1, 2, 3)
'    Range("a1:c1") = arr
'    arr = Range("a1:a3")
'    Range("b1:b3") = arr
'arr = Range("a1:a3")
'Range("a1:c1") = WorksheetFunction.Transpose(arr)
arr = Range("a1").CurrentRegion
Range("a5:c10") = WorksheetFunction.Transpose(arr)
End Sub

for循环遍历数组


image.png
Sub test()
arr = Range("a1").CurrentRegion
    For i = 2 To 4
        Cells(i + 5, 1) = arr(i, 1)
        For j = 2 To 3
            totalResult = totalResult + arr(i, j)
        Next
        Cells(i + 5, 2) = totalResult
        totalResult = 0
    Next
End Sub

数组的声明


image.png
Sub test()
    '生成一维数组,数组下标从0开始
'    Dim arr(4)
'as integer指定数组的类型为数值类型
'    Dim arr(3) As Integer
    '生成一维数组,数组下标从1开始
'    Dim arr(1 To 3)
    '声明二维数组
    Dim arr(1 To 3, 1 To 2)
End Sub

动态数组


image.png
Sub test()
    Dim arr(), brr()
    arr = Range("a7").CurrentRegion
    For i = 1 To 4
        If arr(i, 1) = Range("d7").Value Then
            n = n + 1
            'redim重新定义数组大小,preserve重新定义数组大小时,不清除以前的值
            ReDim Preserve brr(n)
            brr(n) = arr(i, 2)
        End If
    Next i
    MsgBox WorksheetFunction.Sum(brr)
End Sub

声明数组时使用变量,使用redim声明数组

Sub test()
   i = 1 + 1
   '如果声明数组时,使用了变量,那么定义数组应该使用redim关键字
   ReDim arr(1 To i)
End Sub

数组的ubound


image.png
Sub test()
   Dim arr(1 To 3, 2 To 5)
   '返回数组一维的上标
   MsgBox UBound(arr, 1)
   '返回数组二维的上标
   MsgBox UBound(arr, 2)
    '返回数组二维的下标
   MsgBox LBound(arr, 2)
End Sub
image.png
Sub test()
   Dim arr(), brr(1 To 40, 1 To 3)
   arr = Range("a1").CurrentRegion
   For i = 2 To UBound(arr)
        For j = 2 To UBound(arr, 2)
            n = n + 1
            brr(n, 1) = arr(i, 1)
            brr(n, 2) = arr(1, j)
            brr(n, 3) = arr(i, j)
        Next
   Next
   Range("e2").Resize(UBound(brr), 3) = brr
End Sub

利用数组进行冒泡排序

Sub test()
   arr = [a10:d10]
   arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
   For i = 1 To UBound(arr) - 1
        For j = 1 To UBound(arr) - i
            If arr(j) > arr(j + 1) Then
                temp = arr(j + 1)
                arr(j + 1) = arr(j)
                arr(j) = temp
            End If
        Next
   Next
   Range("a11").Resize(1, 4) = arr
End Sub

拆分函数split


image.png
Sub test()
   Dim str As String
   str = "zhang,li,zhao"
   arr = Split(str, ",")
   For i = LBound(arr) To UBound(arr)
    MsgBox arr(i)
   Next
End Sub

join函数


image.png
Sub test()
   Dim arr()
   arr = Array(1, 2, 3)
   MsgBox Join(arr, "-")
End Sub

筛选函数filter


image.png
Sub test()
   arr = Array(12, 142, 43)
   brr = Filter(arr, "1")
   MsgBox Join(brr, "-")
End Sub

工作表函数


image.png
Sub test()
    arr = [a1].CurrentRegion
    brr = WorksheetFunction.Index(arr, 0, 1)
    brr = WorksheetFunction.Transpose(brr)
    r = WorksheetFunction.Match([e1], brr, 0)
    Range("d2:e2") = WorksheetFunction.Index(arr, r, 0)
End Sub

数组去除空值


image.png
Sub test()
    arr = WorksheetFunction.Transpose(Range("a1:a10"))
    t = Join(arr)
    t = WorksheetFunction.Trim(t)
    arr = Split(t)
    Range("b1:b6") = WorksheetFunction.Transpose(arr)
End Sub

清空数组

Sub test()
    Dim arr()
    arr = Array("zhagn", "li")
    '使用erase删除指定数组中的数据
    Erase arr
    MsgBox 1
End Sub

提取数组的唯一值

Sub test()
    On Error Resume Next
    Dim brr()
    arr = Range("a1:a11")
    ReDim brr(1 To UBound(arr))
    For i = LBound(arr) To UBound(arr)
  '判断a数组中的项,在b数组中是否存在,如果不存在就放到b数组
        n = WorksheetFunction.Match(arr(i, 1), brr, 0)
        If n = "" Then
            j = j + 1
            brr(j) = arr(i, 1)
        End If
        n = ""
    Next
    MsgBox Join(brr)
End Sub

字典的add、keys、items方法

Sub test()
    Set dic = CreateObject("scripting.dictionary")
  '该方法添加条目到字典
    dic.Add "zhang", "san"
    dic.Add "li", "si"
'返回字典的所有条目
    arr = dic.items
    MsgBox arr(0)
'返回字典的所有键
    brr = dic.keys
    MsgBox brr(0)
End Sub

字典的exists、Remove、RemoveAll方法

Sub test()
    Set dic = CreateObject("Scripting.dictionary")
    dic("1") = 1
    '判断是否存在对应的键
    MsgBox dic.exists("1")
    '删除对应的键和值
    dic.Remove ("1")
    '删除所有对键和值
    dic.RemoveAll
End Sub

字典的count、comparemode属性

Sub test()
    Set dic = CreateObject("Scripting.dictionary")
    '设置字典的键是否区分大小写,0为区分,1为不区分,必须在未填写进值之前设置
    dic.comparemode = 1
    dic("1") = 1
    dic.Item("2") = 2
    dic.Key("2") = 3
    '返回字典中键的总数
    MsgBox dic.Count
End Sub

正则表达式

Sub test()
    Dim sj As Variant, ss As Variant
    '后期绑定
    Set reg = CreateObject("vbscript.regexp")
    With reg
        '设置全局搜索
        .Global = True
        '设置匹配模式
        .Pattern = "\d+"
        '执行匹配
        Set sj = .Execute("我123")
        For Each ss In sj
            MsgBox ss
        Next
    End With
End Sub

正则表达式replace替换字符串

Sub test()
    Dim sj As Variant, ss As Variant
    '后期绑定
    Set reg = CreateObject("vbscript.regexp")
    With reg
        '设置全局搜索
        .Global = True
        '设置匹配模式
        .Pattern = "\d+"
        '执行匹配
        Set sj = .Execute("我123")
        For Each ss In sj
            'Replace替换字符串
            MsgBox .Replace(ss, "**")
        Next
    End With
End Sub

正则表达式test方法

Sub test()
    Dim sj As Variant, ss As Variant
    '后期绑定
    Set reg = CreateObject("vbscript.regexp")
    With reg
        '设置全局搜索
        .Global = True
        '设置匹配模式
        .Pattern = "\d+"
        '执行匹配
        If .test("d122") Then
            MsgBox "数据匹配正则表达式"
        End If
    End With
End Sub

设置指定字符串对应字符的背景颜色

Sub test1()
    '设置指定字符串对应字符的背景颜色
    [i7].Characters(2, 3).Font.Color = 255
End Sub

排除匹配

Sub test()
    Dim sj As Variant, ss As Variant
    '后期绑定
    Set reg = CreateObject("vbscript.regexp")
    With reg
        '设置全局搜索
        .Global = True
        '设置匹配模式:匹配不是数字的字符串,^符号代表取非操作
        .Pattern = "[^\d+]+"
        '执行匹配
        Set sj = .Execute("cdasd212")
        For Each ss In sj
            MsgBox ss
        Next
    End With
End Sub

后向引用

Sub test()
    Dim sj As Variant, ss As Variant
    '后期绑定
    Set reg = CreateObject("vbscript.regexp")
    With reg
        '设置全局搜索
        .Global = True
        '\1代表后向引用前面第一个括号内的内容
        .Pattern = "(\d{3}).*\1"
        '执行匹配
        MsgBox .test("123za12")
    End With
End Sub

贪婪与懒惰匹配


image.png

muiltiline多行模式


image.png

零宽断言
image.png

image.png

匹配引号


image.png

自定义函数
image.png

image.png

自定义函数默认参数
image.png

事件
image.png

image.png

记录工作表修改时间


image.png

表单组件-单选框
image.png

image.png

image.png

多个单选框放入框架中
image.png

image.png

表单组件-复选框
image.png

image.png

image.png

表单组件-复合框
image.png

image.png

image.png

表单组件-listview控件
工具栏加载list控件
image.png

关于附加组件后显示“未知”,无法调用的问题。
image.png

解决方法是注册MSCOMCTL.OCX


image.png

将excel中的数据显示到listview中
image.png

image.png
'添加listview的表头
Private Sub CommandButton1_Click()
    Dim i As Integer, columnNum As Integer
    With ListView1
        columnNum = Range("a1").End(xlToRight).Column
        For i = 1 To columnNum
            .ColumnHeaders.Add i, , Cells(1, i).Value, .Width / columnNum, lvwColumnLeft
        Next
        .Gridlines = True
        .FullRowSelect = True
        .View = lvwReport
    End With
End Sub
'添加listview的数据
Private Sub CommandButton2_Click()
    Dim i As Integer, j As Integer, rowNum As Integer, columnNum As Integer, listItem As listItem
    With ListView1
        columnNum = Range("a1").End(xlToRight).Column
        rowNum = Range("a1").End(xlDown).Row
        For i = 2 To rowNum
            '每一条数据为一个listItem
            Set listItem = .ListItems.Add()
            '每一条数据的第一列为Text
            listItem.Text = Cells(i, 1)
            For j = 2 To columnNum
            '每一条数据从第二列开始为SubItems
                listItem.SubItems(j - 1) = Cells(i, j)
            Next
        Next

    End With
End Sub
最后编辑于
©著作权归作者所有,转载或内容合作请联系作者
平台声明:文章内容(如有图片或视频亦包括在内)由作者上传并发布,文章内容仅代表作者本人观点,简书系信息发布平台,仅提供信息存储服务。

推荐阅读更多精彩内容