写在前面

研一寒假，闲来无事，就想着学点技能。至于为啥选择VBA，记不清了，应该是刷到了相关视频，看到excelvba一键批量处理数据的强悍，由此产生了兴趣。一开始是看的B站王佩丰的VBA视频（现在由于版权问题，没人再敢上传了），第一遍很吃力，看完一遍感觉没学到啥。后面，结合自己的数据去学习，跟着写代码，稍微有点收获。下面分享记录下自己使用过的代码，分为两个部分，一是自定义的函数，二是自定义的功能。由于是新手写的不规范,还有部分不是通用的，我自己本人再调用可能也需要花时间看代码再去使用。

自定义函数

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
'提取包含分隔符的字符串。（使用数据分裂也能实现）
Function tqzf(STR As String, str1 As String, i As Integer)
tqzf = Split(STR, str1)(i - 1)
End Function
'提取身份证里面的生日信息
Function SFZSR(STR)
SFZSR = Format(DateSerial(Mid(STR, 7, 4), Mid(STR, 11, 2), Mid(STR, 13, 2)), "yyyy/m/d")
End Function
'人民币大写
Function YuanCapital(Amountin)
    YuanCapital = Replace(Application.Text(Round(Amountin + 0.00000001, 2), "[DBnum2]"), ".", "元")
    YuanCapital = IIf(Left(Right(YuanCapital, 3), 1) = "元", Left(YuanCapital, Len(YuanCapital) - 1) & "角" & Right(YuanCapital, 1) & "分", IIf(Left(Right(YuanCapital, 2), 1) = "元", YuanCapital & "角", IIf(YuanCapital = "零", "", YuanCapital & "元整")))
    YuanCapital = Replace(Replace(Replace(Replace(YuanCapital, "零元零角", ""), "零元", ""), "零角", "零"), "-", "负")
End Function
'删除空白表，不可直接使用
Public Function IsBlankSht(Sh As Variant) As Boolean
    If TypeName(Sh) = "String" Then Set Sh = Worksheets(Sh)
    If Application.CountA(Sh.UsedRange.Cells) = 0 Then
        IsBlankSht = True
    End If
End Function
'提取数字
Function EXTNUM(STR As String)
Set regx = CreateObject("vbscript.regexp")
With regx
    .Global = True
    .Pattern = "\D"
    EXTNUM = .Replace(STR, "")
End With
End Function
'提取中文
Function EXTHZ(STR As String)
Set regx = CreateObject("vbscript.regexp")
With regx
    .Global = True
    .Pattern = "\w"
    EXTHZ = .Replace(STR, "")
End With
End Function
'提取英文
Function EXTEN(STR As String)
Set regx = CreateObject("vbscript.regexp")
With regx
    .Global = True
    .Pattern = "[^a-zA-Z]"
    EXTEN = .Replace(STR, "")
End With
End Function
'计算出现在元或者块前面（如4元，100块）数字之和（即计算金钱之和，只能相加）
Function MONEYSUM(STR As String)
Dim i As Integer, j As Double, m As Variant
Set regx = CreateObject("vbscript.regexp")
With regx
    .Global = True
    .Pattern = "\d+\.?\d?(?=[元块])"
    Set mat = .Execute(STR)
End With
For Each m In mat
    j = j + m * 1
Next
MONEYSUM = j
End Function
'根据身份证号前六位确定归属地
Function SFZDZ(rng As Range)
Dim dic As Object
Dim conn As Object, i As Integer
Dim arr()
Set conn = CreateObject("adodb.connection")
Set dic = CreateObject("Scripting.Dictionary")
conn.Open "Provider = Microsoft.ACE.OLEDB.12.0;Data Source=F:\Excel\ADO固定数据库\身份证号前6位对应归属地.xlsx;extended properties=""excel 12.0;HDR=YES"""
arr = Application.WorksheetFunction.Transpose(conn.Execute("select * from [Sheet1$]").GetRows)
For i = 1 To UBound(arr)
    dic.Add arr(i, 1), arr(i, 2)
Next
K = Left(rng, 6)
SFZDZ = dic(K * 1)
conn.Close
End Function
'根据身份证号的7到14位确定年龄（周岁）
Function SFZNN(str2 As String)
Dim STR As String, str1 As String
    STR = VBA.Mid(str2, 7, 8)
    str1 = VBA.DateSerial(Left(STR, 4), Mid(STR, 5, 2), Right(STR, 2))
    SFZNN = VBA.Int(DateDiff("d", str1, Date) / 365)
End Function
'根据身份证号倒数第二位确定性别
Function SFZXB(rng As Range)
Dim i As Integer
    i = VBA.Mid(rng, 17, 1) * 1
    SFZXB = VBA.IIf(i Mod 2, "男", "女")
End Function
'根据出身日期确定生肖
Function SFZSX(rng As Range)
Dim arr()
Dim i As Integer
i = Year(VBA.Format(rng, "yyyy/m/d")) Mod 12
arr = Array("鸡", "狗", "猪", "鼠", "牛", "虎", "兔", "龙", "蛇", "马", "羊", "猴")
If i = 0 Then
    SFZSX = arr(11)
    Else: SFZSX = arr(i - 1)
End If
End Function
'根据出生日期确定星座
Function SFZXZ(rng As Range)
Dim arr(), arr1(), arr2()
Dim i As Double
i = Format(rng, "m.dd")
arr = [{0,"魔羯座";1.2,"水瓶座";2.19,"双鱼座";3.21,"白羊座";4.2,"金牛座";5.21,"双子座";6.22,"巨蟹座";7.23,"狮子座";8.23,"处女座";9.23,"天秤座";10.24,"天蝎座";11.23,"射手座";12.22,"魔羯座"}]
arr1 = Application.WorksheetFunction.Index(arr, 0, 1)
arr2 = Application.WorksheetFunction.Index(arr, 0, 2)
SFZXZ = Application.WorksheetFunction.Lookup(i, arr1, arr2)
End Function

自定义功能

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
'根据A列数据命名并新建表
Sub 建表()
Dim i As Integer, arr(), j As Integer
i = Sheets(1).Range("a200").End(xlUp).Row
    If i = 1 Then
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = Range("a1")
    Else
arr = Range("a1:a" & i)
For j = 1 To i
   Sheets.Add(after:=Sheets(Sheets.Count)).Name = arr(j, 1)
Next
End If
Sheets(1).Select
End Sub
'抓取一个工作目录下所有工作簿，把每个工作簿里面的每张表新建成工作簿然后另存在一个文件夹下(此次示例在f盘Excel文件夹下）(此代码需要复制到工作簿的模块下运行，已经解决了，看第二个注释）
Sub 新建工作簿()
Dim str As String, i As Integer, wb As Workbook, sht As Worksheet, str1 As String, wb1 As Workbook, str5 As String
Dim str2 As String, str3 As String, str4 As String, t
Excel.Application.ScreenUpdating = False
t = Timer
str3 = InputBox("intut目录名") '要打开进行操作的文件夹
str4 = InputBox("output目录名")
  str = Dir("f:\Excel\" & str3 & "\*.xlsx")
  For i = 1 To 100
  str1 = Split(str, ".")(0)
  Set wb = Workbooks.Open("f:\Excel\" & str3 & "\" & str)
     For Each sht In Sheets
     str2 = sht.Name
        sht.Copy
        Set wb1 = ActiveWorkbook
        str5 = wb1.Name                '最新建的工作簿立即把名字储存下来
        Workbooks(str5).SaveAs Filename:="f:\Excel\" & str4 & "\" & str1 & "_" & str2 & ".xlsx"
        Workbooks(str1 & "_" & str2 & ".xlsx").Close
      Next
    str = Dir
    wb.Close
    If str = "" Then
    Exit For
    End If
 Next
Excel.Application.ScreenUpdating = True
MsgBox "处理完成！共用时" & Timer - t & "秒"
End Sub
'表的左上角区域转置
Sub 转置()
Dim i As Integer, j As Integer, arr(), rng As Range
i = Range("a1").End(xlDown).Row
j = Range("a1").End(xlToRight).Column
arr = Range(Cells(1, 1), Cells(i, j))
Range(Cells(1, 1), Cells(i, j)).ClearContents
Set rng = Range("a1")
Set rng = rng.Resize(UBound(arr, 2), UBound(arr, 1))
rng.ClearContents
rng.Value = Application.Transpose(arr)
End Sub

'删除除了sheets（1）以外的所有表
Sub 删除表()
Dim i As Integer, j As Integer
j = Sheets.Count - 1
Application.DisplayAlerts = False
    For i = 1 To j
    Sheets(2).Delete
    Next
Application.DisplayAlerts = True
End Sub
'固定目录下的多个excel文件合并到一张表里(结果：一张表）
Sub 文件合并()
Dim str As String
Dim wb As Workbook, sht As Worksheet
Dim i As Integer, j As Integer, k As Integer, l As Integer
Excel.Application.ScreenUpdating = False
str = Dir("F:\Excel\import data\*.xls*")
For i = 1 To 100
    Set wb = Workbooks.Open("F:\Excel\import data\" & str)
    str = Dir
        For Each sht In wb.Worksheets
        If sht.Range("a1") <> "" Then
            sht.UsedRange.Copy
            Workbooks("工作簿1").Sheets(1).Activate
            Range("a" & k + 1).Select
            ActiveSheet.Paste
        k = Sheets(1).Range("a1").End(xlDown).Row
        End If
        Next
wb.Close
    If str = "" Then
        Exit For
    End If
Next
Range("a1").Select
Excel.Application.ScreenUpdating = True
End Sub
'自选excel文件，将选定excel文件的每张表放到一个文件（结果：多张表）
Sub 自选合并文件()
Dim arr()
Dim wb As Workbook, wb1 As Workbook
Dim sht As Worksheet
Set wb1 = ActiveWorkbook
Set sht = ActiveSheet
On Error Resume Next
arr = Application.GetOpenFilename("excel文件,*.xls*", , , , True)
Excel.Application.ScreenUpdating = False
If arr(1) <> "False" Then
    For i = LBound(arr) To UBound(arr)
        Set wb = Workbooks.Open(arr(i))
        For Each sht In wb.Worksheets
            If sht.Range("a1") <> "" Then
            sht.Copy after:=wb1.Sheets(wb1.Sheets.Count)
            wb1.Sheets(wb1.Sheets.Count).Name = Split(wb.Name, ".")(0) & sht.Name
            End If
        Next
        wb.Close
    Next
End If
Excel.Application.ScreenUpdating = True
End Sub
'将从其他文档复制的带有固定分隔符的文字分开到一列
Sub 将字符串按指定字符分开()
Dim arr As Variant, str As String
str = InputBox("按照啥字符分")
    If InStr(ActiveCell, str) < 1 Then
        MsgBox "请选中要分裂的数据！" & Chr(13) & "或者检查输入的字符是否正确！"
        Exit Sub
    End If
arr = Split(Cells(ActiveCell.Row, ActiveCell.Column), str)
Cells(1, 1).Resize(UBound(arr) + 1, 1) = Application.Transpose(arr)
End Sub
'查找实例1
Sub 当前区域查找1返回找到的地址及其行标和列标()
Dim r As Range, r1 As Range, i As Integer, j As Integer, k As Integer, l As Integer, m As Integer
Dim str As String
j = ActiveCell.End(xlDown).Row + 3
m = ActiveCell.End(xlUp).Row
Set r = ActiveCell.CurrentRegion
Set r1 = r.Find(1, searchorder:=xlByRows, lookat:=xlWhole)
str = r1.Address
    Do
        k = r1.Row
        l = r1.Column
        Range("b" & j + i) = r1.Address
        Range("c" & j + i) = Cells(k, 1)
        Range("d" & j + i) = Cells(m, l)
        i = i + 1
        Set r1 = r.Find(1, after:=r1, searchorder:=xlByRows, lookat:=xlWhole)
    Loop While r1.Address <> str
End Sub
'查找实例2
Sub chazhao()
Dim i As Integer, js As Integer, zh As Integer, j As Integer, find_row As Long
Dim t
Dim back_r As Range, select_r As Range, find_r As Range 'back_r是返回单元格，selec_r是活动单元格，find_r是查找区域
Dim str As String
t = Timer
Set select_r = ActiveCell
Set find_r = select_r.EntireColumn
    For i = 1 To 36
        js = 0    '每次查找的次数归零
        zh = Range("y65536").End(xlUp).Row + 1 '每次循环统计写入数据的最后一行行号并且加一作为写入开始行
        Set back_r = find_r.Find(Range("w" & i), lookat:=xlWhole, searchorder:=xlRows)
        If Not back_r Is Nothing Then
             str = back_r.Address
            Do While Not back_r Is Nothing
                find_row = back_r.Row  '记录返回单元格的行号
                Range(Cells(zh + js, 26), Cells(zh + js, 43)).Value = Range(Cells(find_row, 2), Cells(find_row, 19)).Value '写入数据
                Set back_r = find_r.Find(Range("w" & i), after:=back_r)
                 js = js + 1 '计数
                If back_r.Address = str Then Exit Do
            Loop
        Else: GoTo 1
        End If
    j = zh + js - 1
    Range("y" & zh & ":y" & j) = Range("w" & i).Value '写入KO号列
1
    Next
Set select_r = Nothing
Set find_r = Nothing
MsgBox "处理完毕，用时" & Timer - t & "s"
End Sub

使用方法

  1. 新建一个空白工作簿
  2. 点开发工具，点Visual Basic
  3. 在ThisWorkbook右键插入一个模块
  4. 将自定义函数代码复制进去
  5. 文件另存为.xlam(加载宏)文件，文件名自己随便取一个，比如“张三的函数库”。保存路径：C:\Users\你的电脑用户名\AppData\Roaming\Microsoft\AddIns
  6. excel加载项勾选.xlam文件名

加载项

自定义功能，同样操作，只不过想要把功能放到菜单栏需要去设置添加下。自定义函数，直接像输入内置函数使用即可，比如在单元格输入=tqzf,就会调用提取字符串函数

其它脚本

  • VBA中find函数使用实例
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
#示例1
Sub 当前区域查找1返回找到单元格的地址及其行标和列标()
Dim r As Range, r1 As Range, i As Integer, j As Integer, k As Integer, l As Integer, m As Integer
Dim str As String
j = ActiveCell.End(xlDown).Row + 3
m = ActiveCell.End(xlUp).Row
Set r = ActiveCell.CurrentRegion
Set r1 = r.Find(1, searchorder:=xlByColumns, lookat:=xlWhole)
str = r1.Address
    Do
        k = r1.Row
        l = r1.Column
        Range("c" & j + i) = r1.Address
        Range("d" & j + i) = Cells(k, 1)
        Range("e" & j + i) = Cells(m, l)
        i = i + 1
        Set r1 = r.Find(1, after:=r1, searchorder:=xlColumns, lookat:=xlWhole)
    Loop While r1.Address <> str
End Sub


# 示例2
Sub chazhao()
Dim i As Integer, js As Integer, zh As Integer, j As Integer, find_row As Long
Dim t
Dim back_r As Range, select_r As Range, find_r As Range 'back_r是返回单元格，selec_r是活动单元格，find_r是查找区域
Dim str As String
t = Timer
Set select_r = ActiveCell
Set find_r = select_r.EntireColumn
    For i = 1 To 36
        js = 0    '每次查找的次数归零
        zh = Range("y65536").End(xlUp).Row + 1 '每次循环统计写入数据的最后一行行号并且加一作为写入开始行
        Set back_r = find_r.Find(Range("w" & i), lookat:=xlWhole, searchorder:=xlRows)
        If Not back_r Is Nothing Then
             str = back_r.Address
            Do While Not back_r Is Nothing
                find_row = back_r.Row  '记录返回单元格的行号
                Range(Cells(zh + js, 26), Cells(zh + js, 43)).Value = Range(Cells(find_row, 2), Cells(find_row, 19)).Value '写入数据
                Set back_r = find_r.Find(Range("w" & i), after:=back_r)
                 js = js + 1 '计数
                If back_r.Address = str Then Exit Do
            Loop
        Else: GoTo 1
        End If
    j = zh + js - 1
    Range("y" & zh & ":y" & j) = Range("w" & i).Value '写入KO号列
1
    Next
Set select_r = Nothing
Set find_r = Nothing
MsgBox "处理完毕，用时" & Timer - t & "s"
End Sub