做了几个月的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一览
改变文字颜色
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
网友评论