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
颜色索引-Range属性
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️⃣—创建数组存放数据
通过数组可以快速对数据进行处理
前提：表格数据须规范，不考虑合并单元格
一维数组：数字(1,2,3,4)，字符串(a,b,c,d)
二维数组：((1,1),(1,2),(1,3),(2,1),(2,2),(2,3)) 表格结构、行列转置、计算、遍历、统计…
多维数组：不是很熟悉，不敢乱说（￣□￣｜｜）
简单介绍静态数组、动态数组的使用
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 .[A1048576].End(xlUp).Row
ReDim Preserve SupArr(n) ' 给动态数组重定义一个实际的大小
n = n + 1
SupArr(n - 1) = .Cells(i, 3).Value ' 存到动态数组里去
Next i
End With
End Sub
Tp3️⃣ 创建字典存放数据
通过字典可以快速对数据进行处理
存放键值对关系，key具有唯一性，
参数：count，keys，values，Item
需要创建字典对象后使用
'与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
未完待续、、、
期待下次相遇
644
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
