Excel VBA常用代码总结

做了几个月的Excel VBA，总结了一些常用的代码，我平时编程的时候参考这些代码，基本可以完成大部分的工作，现在共享出来供大家参考。

说明：本文为大大佐原创，但部分代码也是参考百度得来。

初始化

Dim rng As Range, first_row, last_row, first_col,last_col,i, path As String
'intersect语句避免选择整列造成无用计算
Set rng = Intersect(ActiveSheet.UsedRange, Selection)
'选中区域开始行号
first_row = rng.Row
'选中区域结束行号
last_row = first_row + rng.Rows.Count - 1
'选中区域开始列号
first_col = rng.Column
'选中区域结束列号
last_col = first_col + rng.Column .Count - 1
'获取sheet1
Set sh = Sheets("sheets1")

'提示框确认，会暂停程序执行
MsgBox "完成任务成功"
For i = first_row To last_row Step 1 '正序循环 从 first_row 到 last_row 每次循环+1
Next i
For i = 5 To 1000 Step 1 '正序循环 5 到1000 每次循环+1
Next i
If i Mod 2 = 0 Then ' 判断i 对2取余为0则真
MsgBox "等于0"
Else
MsgBox "不等于0"
End If

Dim isBlank As Boolean
isBlank = Cells(i, 1).Value = "" '存储单元格是否为空的结果

改变背景色

Range("A1").Interior.ColorIndex = xlNone

 ColorIndex一览
![image.png](https://img.haomeiwen.com/i3947356/56ca2d9fe468334a.png?imageMogr2/auto-orient/strip%7CimageView2/2/w/1240)
改变文字颜色

Range("A1").Font.ColorIndex = 1

获取单元格

Cells(1, 2)
Range("H7")

获取范围

Range(Cells(2, 3), Cells(4, 5))
Range("a1:c3")
'用快捷记号引用单元格
Worksheets("Sheet1").[A1:B5]

选中某sheet

Set NewSheet = Sheets("sheet1")
NewSheet.Select

选中或激活某单元格

'“Range”对象的的Select方法可以选择一个或多个单元格，而Activate方法可以指定某一个单元格为活动单元格。
'下面的代码首先选择A1:E10区域，同时激活D4单元格：
Range("a1:e10").Select
Range("d4:e5").Activate
'而对于下面的代码：
Range("a1:e10").Select
Range("f11:g15").Activate
'由于区域A1:E10和F11:G15没有公共区域，将最终选择F11:G15，并激活F11单元格。

获得文档的路径和文件名

ActiveWorkbook.Path　　　　'路徑
ActiveWorkbook.Name　　　'名稱
ActiveWorkbook.FullName　 '路徑＋名稱
'或将ActiveWorkbook换成thisworkbook

隐藏文档

Application.Visible = False

禁止屏幕更新

Application.ScreenUpdating = False

禁止显示提示和警告消息

Application.DisplayAlerts = False

文件夹做成

strPath = "C:\temp"
MkDir strPath

状态栏文字表示

Application.StatusBar = "计算中"

双击单元格内容变换

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If (Target.Cells.Row >= 5 And Target.Cells.Row <= 8) Then
If Target.Cells.Value = "●" Then
Target.Cells.Value = ""
Else
Target.Cells.Value = "●"
End If
Cancel = True
End If
End Sub

文件夹选择框方法1

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "文件", 0, 0)
If Not objFolder Is Nothing
Then path= objFolder.self.Path & ""
end if
Set objFolder = Nothing
Set objShell = Nothing

文件夹选择框方法2（推荐）

Public Function ChooseFolder() As String
Dim dlgOpen As FileDialog
Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
With dlgOpen
.InitialFileName = ThisWorkbook.path & ""
If .Show = -1 Then
ChooseFolder = .SelectedItems(1)
End If
End With
Set dlgOpen = Nothing
End Function
'使用方法例：
Dim path As String
path = ChooseFolder()
If path <> "" Then
MsgBox "open folder"
End If

文件选择框方法

Public Function ChooseOneFile(Optional TitleStr As String = "Please choose a file", Optional TypesDec As String = ".", Optional Exten As String = ".") As String
Dim dlgOpen As FileDialog
Set dlgOpen = Application.FileDialog(msoFileDialogFilePicker)
With dlgOpen
.Title = TitleStr
.Filters.Clear
.Filters.Add TypesDec, Exten
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path
If .Show = -1 Then
' .AllowMultiSelect = True
' For Each vrtSelectedItem In .SelectedItems
' MsgBox "Path name: " & vrtSelectedItem
' Next vrtSelectedItem
ChooseOneFile = .SelectedItems(1)
End If
End With
Set dlgOpen = Nothing
End Function

某列到关键字为止循环方法1(假设关键字是end)

Set CurrentCell = Range("A1")
Do While CurrentCell.Value <> "end"
……
Set CurrentCell = CurrentCell.Offset(1, 0)
Loop

某列到关键字为止循环方法2(假设关键字是空字符串)

i = StartRow
Do While Cells(i, 1) <> ""
……
i = i + 1
Loop

"For Each...Next 循环(知道确切边界)
For Each c In Worksheets("Sheet1").Range("A1:D10").Cells
　　If Abs(c.Value) < 0.01 Then c.Value = 0
Next

"For Each...Next 循环(不知道确切边界),在活动单元格周围的区域内循环
For Each c In ActiveCell.CurrentRegion.Cells
If Abs(c.Value) < 0.01 Then c.Value = 0
Next

某列有数据的最末行的行数的取得(中间不能有空行)

lonRow=1
Do While Trim(Cells(lonRow, ２).Value) <> ""
lonRow = lonRow + 1
Loop
lonRow11 = lonRow11 - 1

A列有数据的最末行的行数的取得 另一种方法

Range("Ａ65536").End(xlUp).Row

将文字复制到剪贴板

Dim MyData As DataObject
Set MyData = New DataObject
MyData.SetText Range("H7").Value
MyData.PutInClipboard

取得路径中的文件名

Private Function GetFileName(ByVal s As String)
Dim sname() As String
sname = Split(s, "")
GetFileName = sname(UBound(sname))
End Function

取得路径中的路径名

Private Function GetPathName(ByVal s As String)
intFileNameStart = InStrRev(s, "")
GetPathName = Mid(s, 1, intFileNameStart)
End Function

由模板sheet拷贝做成一个新的sheet

ThisWorkbook.Worksheets("template").Copy After:=ThisWorkbook.Worksheets(Sheets.Count)
Set doc_s = ThisWorkbook.Worksheets(Sheets.Count)
doc_s.Name = "newsheetname" & Format(Now, "yyyyMMddhhmmss")

选中当列的最后一个有内容的单元格(中间不能有空行)

'删除B3开始到B列最后一个有内容的单元格为止的所有内容
Range("B3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents

常量定义

Private Const StartRow As Integer = 3

判断sheet是否存在

Private Function IsWorksheet(ByVal strSeetName As String) As Boolean
On Error GoTo ErrHandle
Dim blnRet As Boolean
blnRet = IsNull(Worksheets(strSeetName))
IsWorksheet = True
Exit Function
ErrHandle:
IsWorksheet = False
End Function

向单元格中写入公式

Worksheets("Sheet1").Range("D6").Formula = "=SUM(D2:D5)"

引用命名单元格区域

Range("MyBook.xls!MyRange")
Range("[Report.xls]Sheet1!Sales"

选定命名的单元格区域

Application.Goto Reference:="MyBook.xls!MyRange"
'或者
worksheets("sheetname").range("rangename").select
Selection.ClearContents

使用Dictionary

'使用Dictionary需要添加参照Microsoft Scripting Runtime
Dim dic As New Dictionary
dic.Add "Table", "Cards" '前面是 Key 后面是 Value
dic.Add "Serial", "serialno"
dic.Add "Number", "surface"
MsgBox dic.Item("Table") '由Key取得Value
dic.Exists("Table") '判断某Key是否存在

将EXCEL表格中的两列表格插入到一个Dictionary中

'函数：在ws工作表中，从iStartRow行开始到没有数据为止，把iKeyCol列和iKeyCol右一列插入到一个字典中，并返回字典。
Public Function SetDic(ws As Worksheet, iStartRow, iKeyCol As Integer) As Dictionary

Dim dic As New Dictionary
Dim i As Integer
i = iStartRow
Do Until ws.Cells(i, iRuleCol).Value = ""

    If Not dic.Exists(ws.Cells(i, iKeyCol).Value) Then
        dic.Add ws.Cells(i, iKeyCol).Value, ws.Cells(i, iKeyCol + 1).Value
    End If

    i = i + 1
Loop

Set SetDic = dic

End Function

判断文件夹或文件是否存在

'文件夹
If Dir("C:\aaa", vbDirectory) = "" Then
MkDir "C:\aaa"
End If
'文件
If Dir("C:\aaa\1.txt") = "" Then
msgbox "文件C:\aaa\1.txt不存在"
end if

 

一次注释多行
    视图---工具栏---编辑   调出编辑工具栏，工具栏上有个“设置注释块” 和 “解除注释快”
打开文件并将文件赋予到第一个参数wb中

'注意，这里的path是文件的完整路径，包括文件名。
Public Function OpenWorkBook(wb As Workbook, path As String) As Boolean
On Error GoTo Err
OpenWorkBook = True

Dim isWbOpened As Boolean
isWbOpened = False

Dim fileName As String
fileName = GetFileName(path)

'check file is opened or either
Dim wbTemp As Workbook
For Each wbTemp In Workbooks
    If wbTemp.Name = fileName Then isWbOpened = True

Next

'open file
If isWbOpened = False Then
    Workbooks.Open path

End If
    
Set wb = Workbooks(fileName)

Exit Function

Err:
OpenWorkBook = False

End Function

 

打开一个文件，并将文件赋予到wb中，将文件的sheet页赋予到ws中的完整代码。（用到了上面的函数）

'If OpenWorkBook(wb, path & "" & "filename") = False Then
MsgBox "open file error."
GoTo Err
End If
wb.Activate
Set ws = wb.Worksheets("sheetname")

打开一个不知道确切名字的文件（文件名中含有serachname），并将文件赋予到wb中，将文件的sheet页赋予到ws中的完整代码。

'用到了上上面的函数OpenWorkBook
'If OpenCompanyFile(wb, path, "searchname") = False Then
MsgBox "open file error."
GoTo Err
End If
wb.Activate
Set ws = wb.Worksheets("sheetname")

'直接使用的函数OpenCompanyFile
Function OpenCompanyFile(wbCom As Workbook, strPath As String, strFileName As String) As Boolean

Dim fs As Variant

fs = Dir(strPath & "\*.xls") 'seach files

OpenCompanyFile = False

Do While fs <> ""
 
    If InStr(1, fs, strFileName) > 0 Then   'file name match
     
        If OpenWorkBook(wbCom, strPath & "\" & fs) = False Then  'open file

            OpenCompanyFile = False
            Exit Do
            
        Else
        
            OpenCompanyFile = True
            Exit Do
            
        End If

    End If
     
    fs = Dir
 
Loop

End Function

 

数字转字母（如1转成A，2转成B）和字母转数字

Chr(i + 64)

比如i=1的时候，Chr(i + 64)=A

Asc(i - 64)

比如i=A的时候，Asc(i - 64)=1
 

复选框总开关实现。假如有10个子checkbox1~checkbox10，还有一个总开关checkbox11，让checkbox11控制1~10的选择和非选择。

Private Sub CheckBox11_Click()
Dim chb As Variant
If Me.CheckBox11.Value = True Then
For Each chb In ActiveSheet.OLEObjects
If chb.Name Like "CheckBox*" And chb.Name <> "CheckBox11" Then
chb.Object.Value = True
End If
Next
Else
For Each chb In ActiveSheet.OLEObjects

     If chb.Name Like "CheckBox*" And chb.Name <> "CheckBox11" Then
        chb.Object.Value = False
     End If
Next

End If
End Sub

 

修改B6单元格所在的pivot的数据源，并刷新pivot

Set pvt = ActiveSheet.Range("B6").PivotTable
pvt.ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"SheetName!R4C2:R" & lngLastRow & "C22", Version:=xlPivotTableVersion10)
pvt.PivotCache.Refresh

将一个图形（比如一个长方形的框"Rectangle 2"）移动到与某个单元格对齐。

ws.Activate
Application.ScreenUpdating = True
ws.Shapes.Range(Array("Rectangle 2")).Select
ws.Shapes.Range(Array("Rectangle 2")).Top = ws.Range("T5").Top
ws.Shapes.Range(Array("Rectangle 2")).Left = ws.Range("T5").Left
Application.ScreenUpdating = False

遍历控件。比如遍历所有的checkbox是否被打挑。

If Me.OLEObjects("CheckBox" & i).Object.Value = True Then
flgChecked = True
end if

得到今天的日期

dateNow = WorksheetFunction.Text(Now(), "YYYY/MM/DD")

在某个sheet页中查找某个关键字

'****************************************************
'Search keyword from a worksheet(not workbook!)
'****************************************************
Public Function SearchKeyWord(ws As Worksheet, keyword As String) As Boolean
Dim var1 As Variant
Set var1 = ws.Cells.Find(What:=keyword, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False)
If var1 Is Nothing Then
SearchKeyWord = False
Else
SearchKeyWord = True
End If
End Function

单元格为空，取不到值的时候，转化为空字符串。Empty to ""
 

'****************************************************
'Empty to ""
'****************************************************
Public Function ChangeEmptyToString(var As Variant) As String
On Error GoTo Err
ChangeEmptyToString = CStr(var)
Exit Function
Err:
ChangeEmptyToString = ""
End Function

 

单元格为空，取不到值的时候，转化为0。Empty to 0
 

'****************************************************
'Empty to 0
'****************************************************
Public Function ChangeEmptyToLong(var As Variant) As Long
On Error GoTo Err
ChangeEmptyToLong = CLng(var)
Exit Function
Err:
ChangeEmptyToLong = 0
End Function

找到某个sheet页中使用的最末行

Me.UsedRange.Rows.Count

遍历文件夹下的所有文件（自定义文件夹和后缀名），并返回文件列表字典

Function SetFilesToDic(ByVal path As String, ByVal extension As String) As Dictionary

Dim MyFile As String
Dim s As String
Dim count As Integer
Dim dic As New Dictionary

If Right(path, 1) <> "\" Then

    path = path & "\"

End If

MyFile = Dir(path & "*." & extension)

count = 1

Do While MyFile <> ""

' If MyFile = "" Then
' Exit Do
' End If

    dic.Add count, MyFile
    
    count = count + 1
    MyFile = Dir
    
Loop

Set SetFilesToDic = dic

' Debug.Print s
End Function
生成log

Sub txtPrint(ByVal txt = "") '第2参数可以指定保存txt文件路径

If myPath = "" Then myPath = ActiveWorkbook.path & "\log.txt"

Open myPath For Append As #1

Print #1, txt

Close #1

End Sub

  [Non-Breaking Space]网页空格在VBA中的处理

替换字符

ChrB(160) & ChrB(0)

上述最终解决方法来自于http://www.blueshop.com.tw/board/FUM20060608180224R4M/BRD2009031011234606U/2.html
 Sdany用户是通过如下思路找到解决方法的（用MidB和AscB）：

Dim I As Integer
For I = 1 To LenB(Cells(1, 1))
Debug.Print AscB(MidB(Cells(1, 1), I, 1))
Next

延时

这段代码在Excel VBA 和VB里都可以用

'***********VB 延时函数定义*************************************
'声明
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
'延时
Public Sub Delay(ByVal num As Integer)
Dim t As Long
t = timeGetTime
Do Until timeGetTime - t >= num * 1000
DoEvents
Loop
End Sub
'***************************************************************

使用方法:
delay 3'3表示秒数 


 

杀掉某程序执行的所有进程
 

Sub KillWord()

Dim Process

For Each Process In GetObject("winmgmts:").ExecQuery("select * from Win32_Process where name='WINWORD.EXE'")
    Process.Terminate (0)
Next

End Sub

 

监视某单元格的变化
 这里最需要注意的问题就是，如果在这个事件里对单元格进行改变，会继续出发此事件变成死循环。

所以要在对单元格进行变化之前加上Application.EnableEvents = False，变完之后再改为True。

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Err
Application.EnableEvents = False
Dim c
Set dicKtoW = SetDic(ThisWorkbook.Sheets("reference"), 3, 1, 2)
Set dicKtoX = SetDic(ThisWorkbook.Sheets("reference"), 3, 1, 3)
For Each c In Target
If c.Column = 11 Then
'MsgBox c.Value
Me.Range("W" & c.Row).Value = GetDic(dicKtoW, c.Value)
Me.Range("X" & c.Row).Value = GetDic(dicKtoX, c.Value)
End If
Next
Set dicKtoW = Nothing
Set dicKtoX = Nothing
Application.EnableEvents = True
Exit Sub
Err:
MsgBox ("Error!Please contact macro developer.")
Application.EnableEvents = True
End Sub

 

On Error的用法
 



1.一般用法

On Error GoTo Label
各种代码
exit sub
Label:
msgbox Err.Description
其他错误处理

2.对于某段代码单独处理

On Error Resume Next
需要监视的代码
If Err.Number <> 0 Then
MsgBox Err.Description
End If
On Error GoTo 0

3.上述两种的结合

On Error Resume Next
需要监视的代码
If Err.Number <> 0 Then
MsgBox Err.Description
Goto Label
End If
On Error GoTo 0
exit sub
Label:
其他错误处理

EXCEL的分组功能和展开收缩功能

'将A列到C列进行分组
Range("A:C").Columns.Group

'默认情况下，分组后的A到C列会是展开状态，如果想让A到C列收缩
Range("A:C").EntireColumn.Hidden=True