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

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

END获取数据边界：

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

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

currentregion:

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

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

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

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

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

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

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

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

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

findnext查询：

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

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

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

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

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

replace替换：

image.png

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

with语句：

image.png

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

DIR函数：

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

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

合并单元格：

image.png

instr函数：

image.png

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

like运算符：

image.png

Sub test()
    MsgBox "12" Like "?2"
End Sub

name语句：

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

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

image.png

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

image.png

解决方法是注册MSCOMCTL.OCX

image.png

将excel中的数据显示到listview中

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

最后编辑于：2024.06.28 10:14:09

人面猴
序言：七十年代末，一起剥皮案震惊了整个滨河市，随后出现的几起案子，更是在滨河造成了极大的恐慌，老刑警刘岩，带你破解...
沈念sama阅读 216,744评论 6赞 502
死咒
序言：滨河连续发生了三起死亡事件，死亡现场离奇诡异，居然都是意外死亡，警方通过查阅死者的电脑和手机，发现死者居然都...
沈念sama阅读 92,505评论 3赞 392
救了他两次的神仙让他今天三更去死
文/潘晓璐我一进店门，熙熙楼的掌柜王于贵愁眉苦脸地迎上来，“玉大人，你说我怎么就摊上这事。” “怎么了？”我有些...
开封第一讲书人阅读 163,105评论 0赞 353
道士缉凶录：失踪的卖姜人
文/不坏的土叔我叫张陵，是天一观的道长。经常有香客问我，道长，这世上最难降的妖魔是什么？我笑而不...
开封第一讲书人阅读 58,242评论 1赞 292
港岛之恋（遗憾婚礼）
正文为了忘掉前任，我火速办了婚礼，结果婚礼上，老公的妹妹穿的比我还像新娘。我一直安慰自己，他们只是感情好，可当我...
茶点故事阅读 67,269评论 6赞 389
恶毒庶女顶嫁案：这布局不是一般人想出来的
文/花漫我一把揭开白布。她就那样静静地躺着，像睡着了一般。火红的嫁衣衬着肌肤如雪。梳的纹丝不乱的头发上，一...
开封第一讲书人阅读 51,215评论 1赞 299
城市分裂传说
那天，我揣着相机与录音，去河边找鬼。笑死，一个胖子当着我的面吹牛，可吹牛的内容都是我干的。我是一名探鬼主播，决...
沈念sama阅读 40,096评论 3赞 418
双鸳鸯连环套：你想象不到人心有多黑
文/苍兰香墨我猛地睁开眼，长吁一口气：“原来是场噩梦啊……” “哼！你这毒妇竟也来了？” 一声冷哼从身侧响起，我...
开封第一讲书人阅读 38,939评论 0赞 274
万荣杀人案实录
序言：老挝万荣一对情侣失踪，失踪者是张志新（化名）和其女友刘颖，没想到半个月后，有当地人在树林里发现了一具尸体，经...
沈念sama阅读 45,354评论 1赞 311
护林员之死
正文独居荒郊野岭守林人离奇死亡，尸身上长有42处带血的脓包…… 初始之章·张勋以下内容为张勋视角年9月15日...
茶点故事阅读 37,573评论 2赞 333
白月光启示录
正文我和宋清朗相恋三年，在试婚纱的时候发现自己被绿了。大学时的朋友给我发了我未婚夫和他白月光在一起吃饭的照片。...
茶点故事阅读 39,745评论 1赞 348
活死人
序言：一个原本活蹦乱跳的男人离奇死亡，死状恐怖，灵堂内的尸体忽然破棺而出，到底是诈尸还是另有隐情，我是刑警宁泽，带...
沈念sama阅读 35,448评论 5赞 344
日本核电站爆炸内幕
正文年R本政府宣布，位于F岛的核电站，受9级特大地震影响，放射性物质发生泄漏。R本人自食恶果不足惜，却给世界环境...
茶点故事阅读 41,048评论 3赞 327
男人毒药：我在死后第九天来索命
文/蒙蒙一、第九天我趴在偏房一处隐蔽的房顶上张望。院中可真热闹，春花似锦、人声如沸。这庄子的主人今日做“春日...
开封第一讲书人阅读 31,683评论 0赞 22
一桩弑父案，背后竟有这般阴谋
文/苍兰香墨我抬头看了看天上的太阳。三九已至，却和暖如春，着一层夹袄步出监牢的瞬间，已是汗流浃背。一阵脚步声响...
开封第一讲书人阅读 32,838评论 1赞 269
情欲美人皮
我被黑心中介骗来泰国打工，没想到刚下飞机就差点儿被人妖公主榨干…… 1. 我叫王不留，地道东北人。一个月前我还...
沈念sama阅读 47,776评论 2赞 369
代替公主和亲
正文我出身青楼，却偏偏与公主长得像，于是被迫代替她去往敌国和亲。传闻我的和亲对象是个残疾皇子，可洞房花烛夜当晚...
茶点故事阅读 44,652评论 2赞 354

excel vba学习

推荐阅读更多精彩内容