职场中常用的 Excel VBA 代码库

对于职场Excel 用户来说，每天都需要与 Excel 打交道，如果能够用好常用的 VBA 代码，可以在一定程度上提高工作效率，让复杂重复的事情况简单便捷。

本人作为 Excel 爱好者，也常常收集些职场常用的 VBA 代码，在这和虫友们一起分享，也希望如果您也有其他常用的 VBA 代码跟贴分享，一起创建Excel VBA 代码库

1、Excel 十字光标代码

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     Cells.Interior.ColorIndex=xlNone
   
3.     Rows(Target.Row).Interior.Color = RGB(255, 0, 0)
   
4.     Columns(Target.Column).Interior.Color = RGB(0, 0, 255)
   
5. End Sub

复制代码

注意：行与列的颜色条可以自己修改颜色，由RGB(X,Y,Z)设定。

2、显示所有隐藏的工作表

1. Sub 显示所有隐藏的工作表()
   
2.         Dim N As Long
   
3.         For N = 1 To Sheets.Count
   
4.                 Sheets(N).Visible = True
   
5.         Next
   
6. End Sub

复制代码

3、Excel将一个工作表根据条件拆分成多个工作簿

1. Sub CFGZB()
   
2.     Dim myRange As Variant
   
3.     Dim myArray
   
4.     Dim titleRange As Range
   
5.     Dim title As String
   
6.     Dim columnNum As Integer
   
7.     myRange = Application.InputBox(prompt:="请选择标题行：", Type:=8)
   
8.     myArray = WorksheetFunction.Transpose(myRange)
   
9.     Set titleRange = Application.InputBox(prompt:="请选择拆分的表头，必须是第一行，且为一个单元格，如：“姓名”", Type:=8)
   
10.     title = titleRange.Value
    
11.     columnNum = titleRange.Column
    
12.     Application.ScreenUpdating = False
    
13.     Application.DisplayAlerts = False
    
14.     Dim i&, Myr&, Arr, num&
    
15.     Dim d, k
    
16.     For i = Sheets.Count To 1 Step -1
    
17.         If Sheets(i).Name <> "数据源" Then
    
18.             Sheets(i).Delete
    
19.         End If
    
20.     Next i
    
21.     Set d = CreateObject("Scripting.Dictionary")
    
22.     Myr = Worksheets("数据源").UsedRange.Rows.Count
    
23.     Arr = Worksheets("数据源").Range(Cells(2, columnNum), Cells(Myr, columnNum))
    
24.     For i = 1 To UBound(Arr)
    
25.         d(Arr(i, 1)) = ""
    
26.     Next
    
27.     k = d.keys
    
28.     For i = 0 To UBound(k) 
    
29.         Set conn = CreateObject("adodb.connection")
    
30.         conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
    
31.         Sql = "select * from [数据源$] where " & title & " = '" & k(i) & "'"
    
32.         Dim Nowbook As Workbook
    
33.         Set Nowbook = Workbooks.Add
    
34.         With Nowbook
    
35.             With .Sheets(1)
    
36.                 .Name = k(i)
    
37.                 For num = 1 To UBound(myArray)
    
38.                     .Cells(1, num) = myArray(num, 1)
    
39.                 Next num
    
40.                 .Range("A2").CopyFromRecordset conn.Execute(Sql)
    
41.             End With
    
42.         End With
    
43.         ThisWorkbook.Activate
    
44.         Sheets(1).Cells.Select
    
45.         Selection.Copy
    
46.         Workbooks(Nowbook.Name).Activate
    
47.         ActiveSheet.Cells.Select
    
48.         Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    
49.                                SkipBlanks:=False, Transpose:=False
    
50.         Application.CutCopyMode = False
    
51.         Nowbook.SaveAs ThisWorkbook.Path & "" & k(i)
    
52.         Nowbook.Close True
    
53.         Set Nowbook = Nothing
    
54.     Next i
    
55.     conn.Close
    
56.     Set conn = Nothing
    
57.     Application.DisplayAlerts = True
    
58.     Application.ScreenUpdating = True
    
59. End Sub

复制代码

VBA 操作方法

• 按"Alt+F11"组合键，打开VBA编辑窗口，依次选择"插入——模块",在右侧窗格插入一个空白模块，将相应代码复制粘贴；
• 关闭VBA编辑窗口，按按"Alt+F8"组合键，打开"宏"对话框，选择运行宏即可实现相应操作。
  

如有不明白，欢迎留言关注。

对筛选后的某列进行序号填充

1. Sub 对筛选后的某列进行填充()
   
2.         Dim M As Long, N As Long
   
3.         For M = 2 To Selection.Count
   
4.                 If Selection(M).EntireRow.Hidden = False Then
   
5.                         N = N + 1
   
6.                         Selection(M) = N
   
7.                 End If
   
8.         Next
   
9. End Sub

复制代码

会数据库就是牛

naturewoods 发表于 2019-12-19 09:51
嗯，宏和VBA有什么关系？

宏后面就是VBA代码，很多VBA代码可以借助录制宏来完成

正在学vba，感觉都快要放弃了，看到你这贴子，还是再坚持一下吧

不懂，学习又太难，最简单的就是付点小费买个插件。

收藏了，提高效率，需要时复制来用用

naturewoods 发表于 2019-12-18 14:54
VBA，什么样的 情况下 要上这个东西？

Excel中有规律又不停重复的一些操作可以用vba，就是消除重复性劳动的。

落叶随风 发表于 2019-4-28 10:16
曾经去学过VBA感觉太痛苦了。

是的，所以收集些职场常用VBA非常有必要，不需要懂VBA只需要会用VBA即可

曾经去学过VBA感觉太痛苦了。

Excel文件自杀代码

1. Private Sub Workbook_Open()
   
2. chk = GetSetting("hhh", "budget", "date", "")
   
3. If chk = "" Then
   
4. termdate = "2011－05－01"
   
5. MsgBox "本工作簿只能使用到" & termdate & vbCrLf & "超过期限将自动销毁!", vbExclamation
   
6. SaveSetting "hhh", "budget", "date", termdate
   
7. Else
   
8. If CDate(chk) <= Now Then
   
9. DeleteSetting "hhh", "budget", "date"
   
10. killme
    
11. Else
    
12. MsgBox "本工作簿只能使用到" & CDate(chk) & vbCrLf & "超过期限将自动销毁!", vbExclamation
    
13. End If
    
14. End If
    
15. 
    
16. End Sub
    
17. 
    
18. Public Sub killme()
    
19. Application.DisplayAlerts = False
    
20. ActiveWorkbook.ChangeFileAccess xlReadOnly
    
21. Kill ActiveWorkbook.FullName
    
22. ThisWorkbook.Close False
    
23. End Sub
    

复制代码

多工作簿汇总到一个表

1. Sub CltSheets()
   
2.    Dim P$, Bookn$, Book$, Keystr1, Keystr2, Shtname$, K&
   
3.   Dim Sht As Worksheet, Sh As Worksheet
   
4.   Application.ScreenUpdating = False
   
5.   Application.DisplayAlerts = False
   
6.   On Error Resume Next
   
7.   With Application.FileDialog(msoFileDialogFolderPicker)
   
8.     .AllowMultiSelect = False
   
9.     If .Show Then P = .SelectedItems(1) Else: Exit Sub
   
10.   End With
    
11.   If Right(P, 1) <> "" Then P = P & ""
    
12.   Keystr1 = InputBox("请输入工作簿名称所包含的关键词" & vbCr & "关键词可以为空，如为空，则默认选择全部工作簿")
    
13.   If StrPtr(Keystr1) = 0 Then Exit Sub '如果用户点击了取消或关闭按钮，则退出程序
    
14.   Keystr2 = InputBox("请输入工作表名称所包含的关键词" & vbCr & "关键词可以为空，如为空，则默认选择符合条件工作簿的全部工作表")
    
15.   If StrPtr(Keystr2) = 0 Then Exit Sub
    
16.   Set Sh = ActiveSheet '当前工作表，赋值变量,代码运行完毕后，回到此表
    
17.   Bookn = Dir(P & "*.xls*")
    
18.   Do While Bookn <> ""
    
19.     If Bookn = ThisWorkbook.Name Then
    
20.       MsgBox "注意：指定文件夹中存在和当前表格重名的工作簿！！" & vbCr & "该工作簿无法打开，工作表无法复制"
    
21.      '当出现重名工作簿时，提醒用户
    
22.     Else
    
23.       If InStr(1, Bookn, Keystr1, vbTextCompare) Then
    
24.      '工作簿名称是否包含关键词，关键词不区分大小写
    
25.         With GetObject(P & Bookn)
    
26.           For Each Sht In .Worksheets
    
27.             If InStr(1, Sht.Name, Keystr2, vbTextCompare) Then
    
28.            '工作表名称是否包含关键词，关键词不区分大小写
    
29.               If Application.CountIf(Sht.UsedRange, "<>") Then
    
30.              '如果表格存在数据区域
    
31.                 Shtname = Split(Bookn, ".xls")(0) & "-" & Sht.Name
    
32.                '复制来的工作表以"工作簿-工作表"形式起名
    
33.                 ThisWorkbook.Sheets(Shtname).Delete
    
34.                '如果已存在相关表名，则删除
    
35.                 Sht.Copy after:=ThisWorkbook.Worksheets(Sheets.Count)
    
36.                 K = K + 1
    
37.                '复制Sht到代码所在工作簿所有工作表的后面，并累计个数
    
38.                 ActiveSheet.Name = Shtname
    
39.                '工作表命名
    
40.               End If
    
41.             End If
    
42.           Next
    
43.           .Close False '关闭工作簿
    
44.         End With
    
45.       End If
    
46.     End If
    
47.     Bookn = Dir '下一个符合条件的文件
    
48.   Loop
    
49.   Sh.Select '回到初始工作表
    
50.   MsgBox "工作表收集完毕，共收集：" & K & "个"
    
51.   Application.ScreenUpdating = True
    
52.   Application.DisplayAlerts = True
    
53. End Sub
    

复制代码

如何将一个Excel工作表的数据拆分成多个工作表

1. Sub 如何将一个Excel工作表的数据拆分成多个工作表()
   
2.     Dim Arr, Rng As Range, Sht As Worksheet, Dic As Object
   
3.     Dim k, t, Str As String, i As Long, lc As Long
   
4.     Application.ScreenUpdating = False '关闭屏幕更新
   
5.     Arr = Range("A1").CurrentRegion.Value
   
6.     lc = UBound(Arr, 2) '求取最后一列的列号
   
7.     Set Rng = Rows(1) '标题行
   
8.     Set Dic = CreateObject("Scripting.Dictionary") '创建字典
   
9.     For i = 2 To UBound(Arr)
   
10.         Str = Arr(i, 3) '订单号，关键字
    
11.         If Not Dic.Exists(Str) Then '如果字典没有关键字
    
12.             Set Dic(Str) = Cells(i, 1).Resize(, lc) '把当前行装入到字典中
    
13.         Else '否则(字典中存在关键字)
    
14.             Set Dic(Str) = Union(Dic(Str), Cells(i, 1).Resize(, lc)) '把行连合起来
    
15.         End If
    
16.     Next
    
17.     k = Dic.Keys '字典关键字集合
    
18.     t = Dic.Items '字典项目集合
    
19.     On Error Resume Next
    
20.     With Sheets
    
21.         For i = 0 To Dic.Count - 1 '循环关键字的个数
    
22.             Set Sht = .Item(k(i)) '给变量赋值(工作表名为关键字)
    
23.             If Sht Is Nothing Then '该工作表不存在则插入一个空工作表
    
24.                 .Add(After:=.Item(.Count)).Name = k(i) '新建的工作表将置于所有工作表之后，并命名为关键字
    
25.                 Set Sht = ActiveSheet '活动工作表给变量
    
26.             Else '否则
    
27.                 Sht.Cells.Clear '清除工作中所有内容和格式
    
28.             End If
    
29.             Rng.Copy Sht.Range("A1") '把标题写入第一行
    
30.             t(i).Copy Sht.Range("A2") '写入其他内容
    
31.             Sht.Cells.EntireColumn.AutoFit '自动调整全工作表单元格的列宽
    
32.             Set Sht = Nothing '变量处于初始状态
    
33.         Next
    
34.     End With
    
35.     Sheets(1).Activate '第1个工作表处于激活状态
    
36.     Application.ScreenUpdating = True '打开屏幕更新
    
37. End Sub
    

复制代码

慢慢学习啊，谢谢。

更改Excel标题状态栏代码

1. Private Sub Workbook_Activate()
   
2. On Error Resume Next
   
3. Application.Caption = "让高效办公流行起来" '改变EXCEL左上标题
   
4. Sheets("首页").Select '并定位在窗口上。。。。。。
   
5. Application.StatusBar = "本系统登录时间： " & Year(Now()) & "年" & Month(Now()) & "月" & Day(Now()) & "日" & "(" & Hour(Now()) & ":" & Minute(Now()) & ":" & Second(Now()) & ")" & " 〓★〓【请关注微信公众号：E同学Excel】〓★〓 " & W
   
6. End Sub

复制代码

虽然不懂VBA但是给你点个赞

第一个代码有一个bug，使用以后，表格就不能再单元格内填充颜色了，已经填充了颜色的会自动被取消

流年再无小新 发表于 2019-4-27 23:00
慢慢学习啊啊啊谢谢

一起相互交流学习。

Antlion 发表于 2019-4-27 23:18
虽然不懂VBA但是给你点个赞

一般不需要真去懂 VBA，只需要把它当成一个工具一样会使用就可以了，自己去学 VBA 是件非常痛苦的事。

mrpathetic 发表于 2019-4-28 06:38
第一个代码有一个bug，使用以后，表格就不能再单元格内填充颜色了，已经填充了颜色的会自动被取消 ...

是的 ，一般情况第一个代码真的不建议去用，因为如果是使用WPS的伙伴，里面有一个阅读模式就是这种聚光灯效果

本代码主要是针对Office用户，想要用到这种聚光灯效果而设立的，在数据核对需要用到的时候可以用一用，平时就不要使用了

WPS阅读模式

需要会用 VBA 即可

谢谢，我跟着一条条试试，希望大神多分享。

VBA，什么样的 情况下 要上这个东西？

最近学习VBA到做窗口控件那里，感觉复杂程度有点大，@简单就好 ，楼主有没有什么可以指点的？

棒，马住

vba宏一直是我想学习的，但是看到这一串类似于编程的东西，我就头大。我先弄一个试试，谢谢分享

一只嘘嘘鬼 发表于 2019-12-18 15:20
Excel中有规律又不停重复的一些操作可以用vba，就是消除重复性劳动的。

嗯，宏和VBA有什么关系？

支持

被VBA折磨过的人，，赶紧整理起来

对于vba头疼的，宏会不会好些