vba常用方法
Excel VBA常用代码总结1
做了几个月的Excel VBA，总结了一些常用的代码，我平时编程的时候参考这些代码，基本可以完成大部分的工作，现在共享出来供大家参考。
说明：本文为大大佐原创，但部分代码也是参考百度得来。
- 改变背景色
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$, Optional myPath$ = "") '第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