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 IfEnd 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 ifSet objFolder = NothingSet 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 Stringpath = 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 = StartRowDo While Cells(i, 1) <> ''……i = i + 1Loop

• 'For Each...Next 循环(知道确切边界)

For Each c In Worksheets('Sheet1').Range('A1:D10').Cells　　If Abs(c.Value) < 0.01 Then c.Value = 0Next

• 'For Each...Next 循环(不知道确切边界),在活动单元格周围的区域内循环

For Each c In ActiveCell.CurrentRegion.Cells    If Abs(c.Value) < 0.01 Then c.Value = 0Next

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

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

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

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

• 将文字复制到剪贴板

Dim MyData As DataObjectSet MyData = New DataObjectMyData.SetText Range('H7').ValueMyData.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').SelectRange(Selection, Selection.End(xlDown)).SelectSelection.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 FunctionErrHandle: IsWorksheet = FalseEnd 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').selectSelection.ClearContents

• 使用Dictionary

'使用Dictionary需要添加参照Microsoft Scripting RuntimeDim dic As New Dictionary dic.Add 'Table', 'Cards' '前面是 Key 后面是 Valuedic.Add 'Serial', 'serialno'dic.Add 'Number', 'surface' MsgBox dic.Item('Table') '由Key取得Valuedic.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 BooleanOn 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 ErrEnd Ifwb.ActivateSet ws = wb.Worksheets('sheetname')

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

'用到了上上面的函数OpenWorkBook'If OpenCompanyFile(wb, path, 'searchname') = False Then    MsgBox 'open file error.'    GoTo ErrEnd Ifwb.ActivateSet ws = wb.Worksheets('sheetname') '直接使用的函数OpenCompanyFileFunction 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         LoopEnd Function

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

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

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

Private Sub CheckBox11_Click()Dim chb As VariantIf 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    NextElse    For Each chb In ActiveSheet.OLEObjects             If chb.Name Like 'CheckBox*' And chb.Name <> 'CheckBox11' Then            chb.Object.Value = False         End If    NextEnd IfEnd Sub

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

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

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

ws.ActivateApplication.ScreenUpdating = Truews.Shapes.Range(Array('Rectangle 2')).Selectws.Shapes.Range(Array('Rectangle 2')).Top = ws.Range('T5').Topws.Shapes.Range(Array('Rectangle 2')).Left = ws.Range('T5').LeftApplication.ScreenUpdating = False

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

If Me.OLEObjects('CheckBox' & i).Object.Value = True Then flgChecked = Trueend 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 IfEnd Function

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

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

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

'****************************************************'Empty to 0'****************************************************Public Function ChangeEmptyToLong(var As Variant) As LongOn Error GoTo Err ChangeEmptyToLong = CLng(var) Exit FunctionErr: ChangeEmptyToLong = 0End 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 sEnd 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 Longt = timeGetTimeDo Until timeGetTime - t >= num * 1000DoEventsLoopEnd 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) NextEnd 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 = TrueExit SubErr:    MsgBox ('Error!Please contact macro developer.')    Application.EnableEvents = TrueEnd Sub

• On Error的用法

1.一般用法On Error GoTo Label 各种代码 exit subLabel: msgbox Err.Description 其他错误处理2.对于某段代码单独处理On Error Resume Next需要监视的代码If Err.Number <> 0 Then MsgBox Err.DescriptionEnd IfOn Error GoTo 03.上述两种的结合On Error Resume Next需要监视的代码If Err.Number <> 0 Then MsgBox Err.Description Goto LabelEnd IfOn Error GoTo 0exit subLabel: 其他错误处理

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

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