VBA常用代码合集

Tp0️⃣—零零散散小功能（持续更新）

• 剪切列
• 替换字符
• 取消复制剪切状态
• 浮点数向上取值
• 区域添加边框
• 区域设置颜色
• 调整列宽、行高
• 待更新

' 小功能集合 Sub Demos() ' 剪切一列到指定列 With ThisWorkbook.Sheets(2) .[AI:AI].Cut .[AE:AE].Select Selection.Insert Shift:=xlToRight End With ' 替换字符，将（空白）替换为空 With worksheet.[C:C] .Replace "(空白)", "" End With ' 取消复制剪贴状态 Application.CutCopyMode = False ' 将带有小数的数据向上取整 NewData = Application.WorksheetFunction.RoundUp(Datas, 0) ' 单元格区域添加边框 .Range("A4:N" & .Range("A9999").End(xlUp).Row).Borders.LineStyle = xlContinuous ' -------------单元格标色------------- ' 指定区域标色 With Range("C2:G9") .Interior.ColorIndex = 0 ' 无填充颜色 .Interior.ColorIndex = 3 ' 红色 .Interior.ColorIndex = 5 ' 蓝色 End With ' 实现自动调整行高、列宽 Rows("1:5").EntireRow.AutoFit ' 调整1至5行行高 Columns("A:AA").EntireColumn.AutoFit ' 调整A至AA列列宽 ' 设置行高、列宽为固定值 Rows("1:5").RowHeight = 15 ' 设置1至5行行高为15 Columns("A:AA").ColumnWidth = 15 ' 设置A至AA列列宽为15 End Sub 

Tp1️⃣—输出活动页面筛选后的行数

' 获取活动页面筛选后的行数 Sub RowCntAfterFilter() Dim rngCell As Range Dim lngRowCnt As Long For Each rngCell In [a1].CurrentRegion.SpecialCells(xlCellTypeVisible).Areas lngRowCnt = lngRowCnt + rngCell.Rows.Count Next rngCell rows_count = lngRowCnt - 1 '可视区行数 MsgBox "筛选后数据行数为：" & rows_count Set rngCell = Nothing End Sub 

Tp2️⃣—创建数组存放数据

Tp2-1 静态数组

Sub SetArray() ’ 静态数组可直接通过 变量名=数组（）的方式设置 array_number = Array(1,2,3,4,5) array_string = Array("张三","李四","王五","Sugar","Smile") ' 可遍历，参数：count，Index 取值：data = array_data(1) ' 赋值 .[A1:A5] = array_number .[B1:B5] = array_string '存放单元格区域数据到数组（二维数组的快捷应用） Dim arr As Variant '定义一个Variant类型的变量，名称为arr arr = Range("A1:C3").Value '将A1:C3中保存的数据存储到数组arr里 Range("E1:G3").Value = arr '将数组ar写入E1:G3单元格区域 End Sub 

Tp2-2 动态数组

Sub VimArray() '自定义动态数组长度n，上界为0 Dim n As Integer n = 0 Dim SupArr() As String ' 定义动态数组存放供应商名称 With ActiveSheet For i = 2 To .[A].End(xlUp).Row ReDim Preserve SupArr(n) ' 给动态数组重定义一个实际的大小 n = n + 1 SupArr(n - 1) = .Cells(i, 3).Value ' 存到动态数组里去 Next i End With End Sub 

Tp3️⃣ 创建字典存放数据

'与Excel单元格结合，创建字典存放数据 Sub RngDict() Dim DicManForm As Object Set DicManForm = CreateObject("Scripting.Dictionary") key_MaxRow = ActiveSheet.[A66666].End(xlUp).Row '活动工作表A列的最后一行的行数 '对A列进行遍历 For key_Row = 2 To key_MaxRow '取A列不重复的值作为字典的key，索引值唯一 KeyXX = ActiveSheet.Cells(key_Row, 1).Value '导入条件：不为空，不重复 If KeyXX <> "" And DicManForm.Exists(KeyXX) = False Then DicManForm.Add KeyXX, key_Row End If Next '通过key值，重设对应的value，key不存在时会报错 DicManForm(key) = value Set DicManForm = Nothing End Sub 

Tp4️⃣ 优化代码运行速度

为了加快代码的执行速度，最简单的方式，将代码的执行过程设置为不显示，可以在代码执行时，临时关闭后续设置：自动重算、自动刷新、弹窗警告
温馨提示：以下代码需要成对出现，设置False后，末尾改回True

Sub AppSetting() ’ 程序开始 With Application .ScreenUpdating = False ' 关闭屏幕刷新 .EnableEvents = False ' 关闭事件触发 .DisplayAlerts = False ' 关闭弹窗提示 End With ' Your Code ' 调用程序运行的主体代码 ’程序末尾 With Application .ScreenUpdating = True ' 恢复屏幕刷新 .EnableEvents = True ' 恢复事件触发 .DisplayAlerts = True ' 恢复弹窗提示 End With End Sub 

好久不见、更新继续

Tp5️⃣ 轻松实现工作簿加密

Sub 解除全部工作表保护() Dim n As Integer For n = 1 To Sheets.Count Sheets(n).Unprotect Next n End Sub Sub 为指定工作表加指定密码保护表() Sheet10.Protect Password:="123" End Sub Sub 在有密码的工作表执行代码() Sheets("1").Unprotect Password:=123 '假定表名为“1”，密码为“123” 打开工作表 Range("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True '隐藏C列空值行 Sheets("1").Protect Password:=123 '重新用密码保护工作表 End Sub 

Tp6️⃣ 通过对话框选择文件-1

' 设置选择文件的弹出窗口，自主选择文件 Sub FilePicker() Open_Path = ThisWorkbook.Sheets("操作界面").[B4] '新建一个对话框对象 Set FileDialogObject = Application.FileDialog(msoFileDialogFilePicker) '配置对话框 With FileDialogObject .Title = "请选择目标文件所在的文件夹：" '添加判断，改变对话框默认打开的路径 '默认打开上次的文件路径 If Open_Path = "" Then .InitialFileName = "C:\" Else .InitialFileName = Open_Path End If End With '显示对话框 FileDialogObject.Show '获取选择对话框选择的文件 Set paths = FileDialogObject.SelectedItems With Sheets("操作界面") .[I:I].Clear file_ = paths.Item(1) '包含绝对路径的文件名 .[B4].Value = paths.Parent.InitialFileName '当前文件所在目录 .[B6].Value = Right(file_, Len(file_) - Len(paths.Parent.InitialFileName)) '获取文件 '选择多个文件时，遍历所选文件，并写入I列 If paths.Count > 1 Then i_Row = 2 For Each Item In paths .Range("I" & i_Row) = Item i_Row = i_Row + 1 Next End If End With End Sub 

Tp7️⃣ 通过对话框选择文件-2

'通过对话框选择文件路径 Sub FolderPicker() Open_Path = ThisWorkbook.Sheets("操作界面").[B4] '新建一个对话框对象 Set FolderDialogObject = Application.FileDialog(msoFileDialogFolderPicker) '配置对话框 '配置对话框 With FolderDialogObject .Title = "请选择目标文件所在的文件夹：" '添加判断，改变对话框默认打开的路径 '默认打开上次的文件路径 If Open_Path = "" Then .InitialFileName = "C:\" Else .InitialFileName = Open_Path End If End With FolderDialogObject.Show '显示对话框 Set paths = FolderDialogObject.SelectedItems '获取选择对话框选择的文件夹 Set fso = CreateObject("Scripting.filesystemobject") '取目标文件 Set myf = fso.getfolder(paths.Item(1)) '从指定路径下获取文件 With Sheets("操作界面") .[I:I].Clear .[B4].Value = paths.Item(1) i_Row = 2 For Each file In myf.Files ' .Range("I" & i_Row) = file '记录绝对路径+文件名 .Range("I" & i_Row) = file.Name '记录文件名 i_Row = i_Row + 1 Next End With End Sub 

Tp8️⃣ 从目录页自动跳转至明细页

小提示：权限分配表中的合并单元格，其中有一个小技巧，请参考另一篇针对筛选单元格的笔记
————如何解决筛选时只显示第一行————

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Rng, oRng As Range ' 定义变量Rng、oRng为单元格 Set Rng = Range("B2:B18") ' 设定Rng为可操作区域单元格 Set oRng = Selection ' 设定oRng为选中单元格 '如果所选单元格在可操作区域外，退出本次运行 If Application.Intersect(oRng, Rng) Is Nothing Then Exit Sub Application.ScreenUpdating = False ' 多选则退出，单选设置筛选值 If Selection.Count > 1 Then Exit Sub Else AimValue = Selection.Value ' 自动跳转至目标工作表进行筛选 With Sheets("权限分配表") If .FilterMode = True Then .ShowAllData .Range("A1").AutoFilter Field:=1, Criteria1:=AimValue, _ Operator:=xlAnd .Activate End With Application.ScreenUpdating = True End Sub 

Tp9️⃣ 选择区域自动设置或取消值

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Dim Rng, oRngs, oRng As Range ' 定义变量Rng、oRng为单元格 Dim Aim As String ' 定义变量Aim为字符串 Aim = "√" ' 设定目标值 Set Rng = Range("D2:H706") ' 设定Rng为可操作区域单元格 Set oRngs = Selection ' 设定oRngs为选中单元格 '如果所选单元格在可操作区域外，退出本次运行 If Intersect(oRngs, Rng) Is Nothing Then Exit Sub ' Selection.FormulaR1C1 = Aim '直接设置所选区域内的值为"√" ' 针对选择区域，有值清空，空值设定Aim For Each oRng In oRngs If oRng.FormulaR1C1 = "" Then oRng.FormulaR1C1 = Aim Else oRng.FormulaR1C1 = "" Next On Error GoTo 0 Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub 

 未完待续、、、 期待下次相遇