VBA常用代码模版
 
Tp0️⃣—零零散散小功能（持续更新）
Tp1️⃣—输出活动页面筛选后的行数
Tp2️⃣—创建数组存放数据
Tp2-1 静态数组
Tp2-2 动态数组
  
Tp3️⃣ 创建字典存放数据
Tp4️⃣ 优化代码运行速度
Tp5️⃣ 轻松实现工作簿加密
Tp6️⃣ 通过对话框选择文件-1
Tp7️⃣ 通过对话框选择文件-2

 
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

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

VBA常用代码大全
 
实战代码大全：
 下载资源链接：https://pan.baidu.com/s/1WgCsOAJ_9jgcpVokJXkhhg
 提取码：3nk4
 其他（图表，excel函数大全，自定义功能区图标id）：
 链接: https://pan.baidu.com/s/1nkY0ZV7BHPYRA_FPAUn9dg
 提取码: qm89
 
 
网络收集整理，仅供个人学习使用

1.用于批量删除图片的VBA代码
 
sub del_pic()
 For Each a In ActiveSheet.Shapes
    If a.Type <> 8 Then
      a.Delete
    End If
   Next a
end sub()
 
2.批量插入图片的VBA代码
 
假设要插入的列为B列，A列是对应的图片名称，图片路径和工作表路径需要一致，插入的图片从B2开始
 
无边距：
 
'无边距
Sub aaimg()
  Dim a As Shape
  Dim rg As Range
  r_num = [a65536].End(xlUp).Row
  '先删除已经存在的
  For Each a In ActiveSheet.Shapes
    If a.Type <> 8 Then
      a.Delete
    End If
   Next a
   '宽度
    Columns("B:B").ColumnWidth = 11
    '高度
    Rows("2:" & r_num).RowHeight = 92
   
   '设置范围
   For Each rg In Range("b2:b" & r_num)
   ActiveSheet.Shapes.AddShape(msoShapeRectangle, rg.Left, rg.Top, rg.Width, rg.Height).Select
   '报错就继续
    On Error Resume Next
   '无边框
   Selection.ShapeRange.Line.Visible = msoFalse
   Rem 设置偏移
   Selection.ShapeRange.Fill.UserPicture ThisWorkbook.Path & "\" & rg.Offset(0, -1) & ".png"
   Next rg
End Sub
 
有边距：
 
'有边距
Sub aaimg()
  Dim a As Shape
  Dim rg As Range
  r_num = [a65536].End(xlUp).Row
  '先删除已经存在的
  For Each a In ActiveSheet.Shapes
    If a.Type <> 8 Then
      a.Delete
    End If
   Next a
   '宽度
    Columns("B:B").ColumnWidth = 11
    '高度
    Rows("2:" & r_num).RowHeight = 92
   
   '设置范围
   For Each rg In Range("b2:b" & r_num)
   ActiveSheet.Shapes.AddShape(msoShapeRectangle, rg.Left + 4, rg.Top + 4, rg.Width - 8, rg.Height - 8).Select
   '报错就继续
    On Error Resume Next
   '无边框
   Selection.ShapeRange.Line.Visible = msoFalse
   Rem 设置偏移
   Selection.ShapeRange.Fill.UserPicture ThisWorkbook.Path & "\" & rg.Offset(0, -1) & ".png"
   Next rg
End Sub
 
3.批量下载文件或图片的VBA代码
 
假设下载文件的url在A列，文件名称在B列，要保存的文件类型在C列
 
Sub downloadimg()
'给定网址下载图片或视频
Dim H, S, f_type, name, filename
'f_type 文件类型  name 文件名称  filename 路径名称
r_num = [a65536].End(xlUp).Row
filename = ThisWorkbook.Path & "\" & "img"
If Dir(filename, vbDirectory) = "" Then  '如果文件不存在
    MkDir filename
    GoTo main
End If

main:
    Set H = CreateObject("Microsoft.XMLHTTP")
    For i = 1 To r_num
        name = Range("b" & i).Value
        If name = "" Then name = i      '为空则默认为数字
        f_type = Range("c" & i).Value
        On Error Resume Next
        H.Open "GET", Range("A" & i), False  '网络中的文件URL
        H.send
        Set S = CreateObject("ADODB.Stream")
        S.Type = 1
        S.Open
        S.write H.Responsebody
        S.savetofile filename & "\" & name & "." & f_type, 2 '本地保存文件名
        S.Close
    Next i
End Sub
 
4.查找本周的周一以及周日
 
Sub ff()
d = "2019/8/12"
MsgBox DateAdd("d", -(Weekday(d, 0) - 1), d)   '周一
MsgBox DateAdd("d", (7 - Weekday(d, 0)), d)    '周日
'MsgBox Weekday(d, 0)
End Sub
 
5.获取最后一列的行号的VBA代码
 
Function get_col(col_num)
 '输出字母形式的列名称
    If col_num <= 26 Then
        col_str = Chr(64 + col_num)
    Else
        b_num = col_num \ 26
        e_num = col_num Mod 26
        If e_num = 0 Then
            col_str = Chr(64 + b_num - 1) + Chr(64 + 26)
        Else
            col_str = Chr(64 + b_num) + Chr(64 + e_num)
        End If
    End If
    get_col = col_str
End Function
 
6.二维数组与一维数组，获取某行与某列，并转为一维数组
 
Sub ar()
Dim arr1(1 To 6, 1 To 3), arr2()
Dim i, j As Integer
For i = 1 To 6
    For j = 1 To 3
        arr1(i, j) = i * j
    Next j
Next i
'获取第三列
arr2 = Application.Transpose(Application.Index(arr1, 0, 3))
'获取第三行
arr2 = Application.Index(arr1, 3, 0)
For i = 1 To UBound(arr2)
    Debug.Print arr2(i)
Next i
End Sub
 
7.打开工作簿，并将该工作表的某个工作表放入数组的VBA代码
 
Function get_arr(file, sh_name)
    '打开一个工作簿，并返回一个数组，第一个为路径，第二个参数为工作表的序号（工作表名称）
    
    Dim wb As Workbook
    Set wb = Workbooks.Open(file)
    wb.Sheets(sh_name).Select
    row_num = [b65536].End(xlUp).Row
    col_num = ActiveSheet.UsedRange.Columns.Count
    col_str = get_col(col_num)   '获取行名称
    arr = Sheets(sh_name).Range("a1:" & col_str & row_num)
    wb.Close False
    Set wb = Nothing
    get_arr = arr
End Function
 
8.循环当前工作簿，对每个工作表进行操作的VBA代码
 
Sub type_sum()
    For Each sht In Sheets
    sh_name = sht.Name
        Sheets(sh_name).Select
        'Call tianchong     '执行某个操作
    Next sht
End Sub
 
9.在当前工作簿增加工作表，如果名字相同会删除
 
Function add_sheet(sh_name)
'添加工作表
'删除旧数据
Application.DisplayAlerts = False
For Each sht In Sheets
    If sht.Name = sh_name Then sht.Delete
Next sht
Application.DisplayAlerts = True
'添加新工作表
Sheets.add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = sh_name
End Function
 
10.打开word并对其中内容进行替换
 
Sub open_wd2(arr)
'循环体
Application.EnableCancelKey = xlDisabled
Dim wd, w_doc As Object
Dim common_path
common_path = "D:\new\"   '输出的文档位置
doc_path="D:\analyse\20191118\计算\模板.docx"  'word模板路径
Set wd = CreateObject("Word.application")
'wd.Visible = True   '设置窗体可见
Set w_doc = wd.Documents.Open(doc_path)
Set myRange = w_doc.Content
'替换内容
For i = UBound(arr) To 2 Step -1
    myRange.Find.Execute FindText:=arr(i, 2), _
    ReplaceWith:=arr(i, 3), Replace:=wdReplaceAll
Next i
w_doc.SaveAs2 common_path & arr(2, 3) & "结果.docx"
w_doc.Close
'退出word程序
wd.Quit
Set wd = Nothing
Set w_doc = Nothing
End Sub

Sub main_func()
Application.EnableCancelKey = xlDisabled
With CreateObject("Wscript.Shell")
    Call .RegWrite("HKEY_CURRENT_USER\Control Panel\International\iLZero", "1")
         '设置小数点前导0显示即 [0.7]格式
End With
ex_path="D:\analyse\模板.xlsx"    'excel模板位置
arr1 = get_arr(ex_path, 1)  '替换的格式，get_arr为上方的函数
arr2 = get_arr(ex_path, 2)  '替换的数据
    For j = 2 To UBound(arr2)
        For k = 2 To UBound(arr1)
            arr1(k, 3) = CStr(arr2(j, k))
        Next k
        open_wd2 (arr1)
    Next j
'With CreateObject("Wscript.Shell")
    'Call .RegWrite("HKEY_CURRENT_USER\Control Panel\International\iLZero", "0")
        '恢复到默认 小数点前导0不显示 [.7]状态
'End With
End Sub
 
运行时，需要复制本文中的5、7函数，同时设置好word模板路径、excel模板路径和输出位置。
 
11.将当前工作表中的公式转换成数值
 
Sub shuzhi()
'公式转为数值
row_num = [a65536].End(xlUp).Row
col_num = ActiveSheet.UsedRange.Columns.Count
col_str = get_col(col_num)
Range("A1:" & col_str & row_num).Copy
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
End Sub
 
12.删除特定行
 
在原有数据上直接修改
 
Sub ffa()
'删除对应行
row_num = [a65536].End(xlUp).Row
 For i = row_num To 1 Step -1
    If Cells(1, i) = "同比" Or Cells(1, i) = "" Then   '此处填写条件
        Columns(i).Delete
    End If
Next i
End Sub
 
先备份再进行删除
 
Function add_sheet(sh_name)
'添加工作表
'删除旧数据
Application.DisplayAlerts = False
For Each sht In Sheets
    If sht.Name = sh_name Then sht.Delete
Next sht
Application.DisplayAlerts = True
'添加新工作表
Sheets.add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = sh_name
End Function

Sub ffa()
'删除对应行
row_num = [a65536].End(xlUp).Row
col_num = ActiveSheet.UsedRange.Columns.Count
col_str = get_col(col_num)
arr=Range("A1:" & col_str & row_num)
add_sheet("删除后")
Sheets("删除后").Range("a1").Resize(row_num, UBound(arr, 2)) = arr
 For i = row_num To 1 Step -1
    If Cells(1, i) = "同比" Or Cells(1, i) = "" Then   '此处填写条件
        Columns(i).Delete
    End If
Next i
End Sub
 
13.判断文件夹和文件是否存在的VBA代码
 
Sub fe()
testfile = "D:\analyse\20191118\计算\new\"
If Dir(testfile, vbDirectory) = "" Then
    MsgBox "不存在"
Else
    MsgBox "存在"
End If
End Sub
 
14.添加引用
 
'Name: Excel Major: 1 Minor: 7 GUID: {00020813-0000-0000-C000-000000000046}
'Name: DAO Major: 5 Minor: 0 GUID: {00025E01-0000-0000-C000-000000000046}
'Name: WMPLib Major: 1 Minor: 0 GUID: {6BF52A50-394A-11D3-B153-00C04F79FAA6}
'Name: VBIDE Major: 5 Minor: 3 GUID: {0002E157-0000-0000-C000-000000000046}
'Name: Office Major: 2 Minor: 5 GUID: {2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}
'Name: stdole Major: 2 Minor: 0 GUID: {00020430-0000-0000-C000-000000000046}
'Name: Word Major: 8 Minor: 5 GUID: {00020905-0000-0000-C000-000000000046}
'Name: VBA Major: 4 Minor: 1 GUID: {000204EF-0000-0000-C000-000000000046}
Sub AutoAddRef()
Dim strGUID As String
strGUID = "{00020905-0000-0000-C000-000000000046}" 'Microsoft Windows Media Player Marjor=1 Minor=0
ThisDocument.VBProject.References.AddFromGuid GUID:=strGUID, Major:=8, Minor:=5
End Sub
 
 

链接：https://pan.baidu.com/s/1vPQaUrZ2UbY7BS4wiHGnXw 
 提取码：68ee