VBA常用代码汇总

一些日常经常用到的VBA代码汇总

VBA中调用SQL处理数据

这里仅提供一个例子，更详细的介绍和使用可参阅
http://smilecoc.vip/2020/03/03/using_sql_in_vba/

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=数据库的密码 这两个参数都不是微软账户的名称和密码，否则会报错

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

选择性粘贴

选择性粘贴的语法为： .PasteSpecial(Paste,Operation,SkipBlanks,Transpose)
比较常用的几个paste参数为：

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

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

用户交互窗口—选择文件

弹出用户交互窗口，让用户可以选择.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  '取消所有列的隐藏
raw.Rows.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

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

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

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

新建一份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_202012.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