大家好，我是讯享网，很高兴认识大家。

一些日常经常用到的VBA代码汇总
本文首发于：
http://smilecoc.vip/2020/06/20/vba_code_collection/

更多文章欢迎关注我的公众号：Smilecoc的杂货铺

VBA中调用SQL处理数据

Sub Query() Dim Conn As Object, Rst As Object Dim strConn As String, strSQL As String Dim i As Integer, PathStr As String Set Conn = CreateObject("ADODB.Connection") Set Rst = CreateObject("ADODB.Recordset") '设置工作簿的完整路径和名称 PathStr = ThisWorkbook.FullName '设置连接字符串,根据Excel版本创建连接 Select Case Application.Version * 1 Case Is <= 11 strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & PathStr Case Is >= 12 strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties=""Excel 12.0;HDR=YES"";""" End Select ' 在这里改SQL查询语句 strSQL = "Select distinct Objective,Landing_Site,Publisher,Device,Ad_type,sum(est_impression) as impression,sum(est_click) as click,sum(est_click)/sum(est_impression) as ctr,sum(net_cost)/sum(est_impression)*1000 as cpm,sum(net_cost)/sum(est_click) as cpc FROM [raw data$] group by Objective,Landing_Site,Publisher,Device,Ad_type having Publisher is not null " '打开数据库链接 Conn.Open strConn '执行查询，并将结果输出到记录集对象 Set Rst = Conn.Execute(strSQL) '在这里改输出的表名 With ThisWorkbook.Sheets("sql data") .Cells.Clear For i = 0 To Rst.Fields.Count - 1 '填写标题 .Cells(1, i + 1) = Rst.Fields(i).Name Next i '在这里改输出的位置与单元格 .Range("A2").CopyFromRecordset Rst .Cells.EntireColumn.AutoFit '自动调整列宽 End With Rst.Close '关闭数据库连接 Conn.Close Set Conn = Nothing Set Rst = Nothing End Sub 

讯享网

插入多行、多列

如下的三句vba代码都可以一次插入一行：

讯享网 Cells(2, 1).EntireRow.Insert Rows(2).Insert Range("2:2").Insert 

插入多列，并添加Insert方法的参数

 thisworkbook.sheets("test").Columns("A:A").Resize(, 5).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 

VBA连接特定的数据库并取数

需要注意的是

1. Provider=sqloledb这一个参数数据库不同的情况下也是不一样的，这里我用的是sql server云数据库，其他的数据库可以另行查找
2. Uid=用户名称;Pwd=数据库的密码 这两个参数都不是微软账户的名称和密码，是数据库（Sa）的账号密码，否则会报错

讯享网Sub getdata_fromdb() Dim Conn As Object, Rst As Object Dim strConn As String, strSQL As String Dim i As Integer, PathStr As String Set Conn = CreateObject("ADODB.Connection") Set Rst = CreateObject("ADODB.Recordset") PathStr = ThisWorkbook.FullName '设置工作簿的完整路径和名称 strConn = "Provider=sqloledb;Server=数据库服务器地址;Database=数据库名称;Uid=用户名称;Pwd=数据库的密码" '定义数据库链接字符串 '#在这里改SQL查询语句 strSQL = "select * from test" Conn.Open strConn Set Rst = Conn.Execute(strSQL) With ThisWorkbook.Sheets("raw") .Cells.Clear For i = 0 To Rst.Fields.Count - 1 .Cells(1, i + 1) = Rst.Fields(i).Name Next i .Range("A2").CopyFromRecordset Rst .Cells.EntireColumn.AutoFit End With Rst.Close Conn.Close Set Conn = Nothing Set Rst = Nothing MsgBox "数据已更新完成" End Sub 

获取最前，后，左，右的行或列

'从第一行向左查找到的第一个非空值单元格的列，即最左的一列的列数 Nextcol=Cells(1,columns.count).End(xlToLeft).Column '从第一列的最后一行向上查找到的第一个非空值单元格的行数.End(xlup)，可以简写为end（3） Nextcol=Cells(rows.count,1).End(xlup).row ‘查找最前的行 Nextcol=Cells(1,1).End(xldown).row ‘查找最前的列 Nextcol=Cells(1,1).End(xlright).column '获取当前使用区域的最后一行 ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row 

选择性粘贴

1. 公式 xlPasteFormulas
2. 数值 xlPasteValues
3. 格式 xlPasteFormats

讯享网 sqldata.Range("A2:o" & sqllastrow).Copy Summary.Range("B9").PasteSpecial Paste:=xlPasteValues '添加值 

使用数组实现复制粘贴为值的效果

使用数组实现复制粘贴的好处在于这种方法不用关心是否有筛选，同时会自动把文本型的数字变为数值型。

Set spsheet = ThisWorkbook.Sheets("test") '先对arr数组赋值 arr = spsheet.Range("A1:Z10") '再将数组里的值赋值到结果区域。UBound(arr,1)为数组的行数，UBound(arr,2)是数组的列数，这样可以实现动态的复制粘贴。如果行数或列数确定也可直接使用固定值 spsheet.[a9].Resize(UBound(arr,1), UBound(arr,2)) = arr 

用户交互窗口–选择文件

弹出用户交互窗口，让用户可以选择.xls;.xlsx;.xlsm格式的文件并打开选择文件

讯享网Sub get_mzdata() MsgBox "请选择输入文件" nm = Application.GetOpenFilename("Excel 文件 ,*.xls*;*.xlsx;*.xlsm", 4, "选择总表") If nm = False Then MsgBox "你没有选择文件,程序将结束" Exit Sub End If Set tp = Workbooks.Open(nm) End Sub 

替换,例如替换AB列里的-

 Thisworkbook.sheets("test").Columns("AB:AB").Replace What:="-", Replacement:="/", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False 

代码分行:如果代码过长的话不利于查看，可以换行书写

讯享网'对于非sql 语句 可以使用 空格+ _换行，例如 if MsgBox("您确认要清空文本框值吗?", vbOKCancel + vbInformation, "提示") = vbOK Then If MsgBox("您确认要清空文本框值吗?", vbOKCancel + _ vbInformation, "提示") = vbOK Then '对于 sql 语句 可以在句末+双引号+空格+下划线，下一句前面+&+空格+双引号,例如 strsql = "Select 采购订单表.状态, 采购订单表.采购订单号, 采购订单表.采购日期, 采购订单表.供应商ID, 采购订单表.经办人" _ & " FROM 采购订单表;" '也可以这样写： a = "Select 采购订单表.状态, 采购订单表.采购订单号, 采购订单表.采购日期, 采购订单表.供应商ID, 采购订单表.经办人" a = a & " FROM 采购订单表;" 

去重

单列去重

讯享网

ActiveSheet.Range("G21:R36").RemoveDuplicates Columns:=12, Header:=xlYes 

多列去重

讯享网Thisworkbook.Sheets("test").Range("$A:$AL").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9), Header:=xlYes 

当然也可以用字典加数组以及SQL等方式实现去重，会更有效率，这里不在赘述

VBA隐藏与取消隐藏

Set raw = ThisWorkbook.Sheets("raw data") '取消工作表的全部隐藏 raw.Columns.Hidden = False '将ak到bk列隐藏 raw.Columns("AK:BK").EntireColumn.Hidden = True '将Columns换为rows即为对行操作 

清除

讯享网Set raw = ThisWorkbook.Sheets("raw data") raw.Range("A2:MM" & raw.Rows.Count).ClearContents'清除内容 raw.Range("A2:MM" & raw.Rows.Count).ClearFormats'清除格式 raw.cells.clear'全部清除 

选取文件夹

可以让用户选取文件夹，并返回文件夹位置

Sub SelectFolder() Dim Path As String With Application.FileDialog(msoFileDialogFolderPicker) If .Show = -1 Then 'FileDialog 对象的 Show 方法显示对话框，并且返回 -1（如果按 OK）和 0（如果按 Cancel） Path = .SelectedItems(1) MsgBox "您选择的文件夹是：" & Path, vbOKOnly + vbInformation '获取到的Path长这个样子："D:\VBA\Report\Format"，Format就是我选中的文件夹的名字 End If End With End Sub 

获取程序运行时间

讯享网t = Timer '中间加入想计时的代码块，这里我随意加上几句代码测试 Set raw = ThisWorkbook.Sheets("raw data") raw.Range("A2:MM" & raw.Rows.Count).ClearContents raw.Range("A2:MM" & raw.Rows.Count).ClearFormats MsgBox Timer - t 

对指定列名进行操作

注意match函数是大小写敏感的

'忽略错误语句，如果Match找不到指定的值也不会报错,可以继续往下运行 On Error Resume Next c = Application.Match("Date", Rows(1), 0) '在第一行查找Date列 If c <> "" then Columns(c).Format 

VBA中调用excel内置函数

讯享网'调用min和max函数 min_age = WorksheetFunction.Min(age.Columns("A")) enddate = Format(WorksheetFunction.Max(rawclean.Columns("AA")), "yyyy/mm/dd") 

调整格式

'一般格式 Columns("AA:AA").NumberFormat = "General" '小数格式 Columns("AA:AA").NumberFormat = "0.00" '日期格式 Columns("AA:AA").NumberFormat = "m/d/yyyy" '百分比格式 Columns("AA:AA").NumberFormat = "0.00%" 

关闭、开启系统提醒，刷新等设置

一般VBA中常用的关闭提示如下，其他的提示设置等暂不赘述

讯享网 Application.ScreenUpdating = False '关闭屏幕更新 Application.DisplayAlerts = False '关闭弹窗警告 Application.AskToUpdateLinks = False '关闭程序询问更新链接提示 '设置为true即可打开 Application.ScreenUpdating = True Application.DisplayAlerts = True Application.AskToUpdateLinks = True 

选择数据区域

'选取指定的范围区域 Sheets(1).Range("A1:D5").select '选择第一行 Rows(1).select Range("1:1").select Rows("1:1").select '选择第一列 Columns(1).select Range("a:a").select '选取包含当前单元格的所有连续的使用区域 Sheets(1).Range("A1").CurrentRegion.Copy '选取sheet1中所有已使用（编辑过的）单元格范围 Worksheets("Sheet1").UsedRange.Select 

选择多个不连续的区域

讯享网'两个或多个引用之间插入逗号，可使用 Range 属性引用多个区域 Worksheets("Sheet1").Range("C5:D9,G9:H16,B14:D18").ClearContents '使用 Union 方法将多个区域合并为一个 Range Sub MultipleRange() Dim r1, r2, myMultipleRange As Range Set r1 = Sheets("Sheet1").Range("A1:B2") Set r2 = Sheets("Sheet1").Range("C3:D4") Set myMultipleRange = Union(r1, r2) myMultipleRange.Font.Bold = True End Sub 

使用数组+字典方法实现Vlookup功能

 Sub Vlookup_byarray() 'Arr为填写vlookup结果的区域 Arr = thisworkbook.sheets("test").Range("a1").CurrentRegion Set d = CreateObject("Scripting.Dictionary") 'd是字典,创建字典 arr1 = Sheets("raw").Range("a1").CurrentRegion 'ARR1就是要v的数据,即原始数据 For i = 2 To UBound(arr1) '对于从Arr1里的所有数据 d(arr1(i, 1)) = arr1(i, 2) '给字典赋值，键在数组第一列，值在数组第2列 Next For i = 2 To UBound(Arr) '遍历Arr的所有数据 '如果结果区域中第三列中的值在字典中存在，就在数组第10列返回其对应的值 If d.exists(Arr(i, 3)) Then Arr(i, 10) = d(Arr(i, 3)) Else Arr(i, 10) = "没有该值，请检查" End If Next d.RemoveAll '清空字典 End Sub 

同时替换多组值

讯享网Sub ReplaceMulValues() Dim myRange As Range, myList As Range lastrow = ThisWorkbook.Sheets("plan").Cells(Rows.Count, 1).End(3).Row 'myRange为原始值区域 'myList 为有替换前值和替换后值的列表区域 Set myRange = ThisWorkbook.Sheets("plan").Range("A6:A" & lastrow) Set myList = ThisWorkbook.Sheets("replacelist").Range("F2:G32") For Each cel In myList.Columns(1).Cells myRange.Replace What:=cel.value, Replacement:=cel.Offset(0, 1).value Next End Sub 

新建一份excel文件

 Sub new_file_result() '创建一个新的excel文件并保存 Set excelApp = CreateObject("Excel.Application") '新建模板文件 Set excelWB = excelApp.Workbooks.Add excelApp.DisplayAlerts = False savePath = ActiveWorkbook.path & "\测试表.xlsx" excelWB.SaveAs savePath excelApp.Quit End Sub 

使用 Workbooks.Add 可以快速新建文件

隐式打开文件

隐式打开文件时用户没有办法看到打开文件的窗口，但是实际上文件还是已经打开的，所以在后面要加上关闭文件的语句。

讯享网Set wb = GetObject("test_.xlsx") a = wb.Sheets("test").Range("B1").Value wb.Close False 

遍历文件夹中的文件

s = xlsx '定义要遍历的文件类型 f = Dir(ThisWorkbook.Path & "\*" & s) '生成查找EXCEL的目录 Do While f <> "" '在目录中循环 If f <> ThisWorkbook.Name Then '如果不是当前打开的工作簿 Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f) '打开文件并赋值为wb start = ThisWorkbook.Sheets("Cover").[B1].Value'对每个文件的操作 wb.Close End If f = Dir Loop 

文件另存并设置密码

Excel文件saveas方法：https://docs.microsoft.com/zh-cn/office/vba/api/excel.workbook.saveas

讯享网filepath="C:\Users\result.xlsx" '另存为文件并设置只读密码 ThisWorkbook.SaveAs Filename:=filepath, writeResPassword:="12345" ‘保存不同的格式，例如由.xls文件保存为.xlsx文件，同时添加打开文件密码 ThisWorkbook.SaveAs Filename:=filepath，FileFormat:=xlOpenXMLWorkbook,Password:="fileOpenPassword" 

字典

判断字典中的键（key）或者值(item)是否为空

If IsEmpty(d.key) = False Then MsgBox "键不为空" end if '如果要判断键对应的值使用d.item 

返回路径

讯享网返回应用程序完整路径 Application.Path 返回当前工作薄的路径 ThisWorkbook.Path 返回当前默认文件路径： Application.DefaultFilePath Application.ActiveWorkbook.Path 只返回路径 Application.ActiveWorkbook.FullName 返回路径及工作簿文件名 Application.ActiveWorkbook.Name 返回工作簿文件名 

筛选

筛选

Range("a1:a100").AutoFilter Field:=1, Criteria1:="筛选条件" '添加筛选，并筛选第一列中内容为筛选条件的数据 Sheets(1).Rows("4:4").AutoFilter ’在第一个sheet中的第四行添加筛选 Sheets(1).AutoFilterMode = False ‘清除所有的筛选，使用这个语句可以实现无论工作表是否处于筛选状态都可以变为未筛选的状态 Range("a1:a100").AutoFilter Field:=1, Criteria1:=Array("a", "b", "d"), Operator:=xlFilterValues’筛选多个值 

反选

如果要选取不等于某个值这样的条件，代码为：

讯享网.Range("B1").AutoFilter Field:=2, Criteria1:="<>#N/A",Operator:=xlFilterValues’筛选B列值不为#N/A的 .Range("B1").AutoFilter Field:=2, Criteria1:="<>#N/A", Criteria2:="<>", Operator:=xlFilterValues‘’筛选B列值不为#N/A和空白的 

需要注意Excel只支持两个条件的反选，而不支持更多个条件的反选。这是因为反选时我们其实是使用筛选中的自定义筛选–不等于，而这一功能只提供了至多两个条件的筛选。

获取当前时间并格式化

a=Format(Now(), "mmdd")'now()获取当前时间 

个人公众号：Smilecoc的杂货铺，欢迎关注！