《Excel VBA常用代码总结1(12页).doc》由会员分享，可在线阅读，更多相关《Excel VBA常用代码总结1(12页).doc（12页珍藏版）》请在taowenge.com淘文阁网|工程机械CAD图纸|机械工程制图|CAD装配图下载|SolidWorks_CaTia_CAD_UG_PROE_设计图分享下载上搜索。
1、- Excel VBA常用代码总结1-第 12 页 改变背景色Range(A1).Interior.ColorIndex = xlNoneColorIndex一览 改变文字颜色Range(A1).Font.ColorIndex = 1 获取单元格Cells(1, 2)Range(H7) 获取范围Range(Cells(2, 3), Cells(4, 5)Range(a1:c3)用快捷记号引用单元格Worksheets(Sheet1).A1:B5 选中某sheetSet NewSheet = Sheets(sheet1)NewSheet.Select 选中或激活某单元格“Range”对象的的Se
2、lect方法可以选择一个或多个单元格，而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 路徑
3、名稱或将ActiveWorkbook换成thisworkbook 隐藏文档Application.Visible = False 禁止屏幕更新Application.ScreenUpdating = False 禁止显示提示和警告消息Application.DisplayAlerts = False 文件夹做成strPath = C:tempMkDir strPath 状态栏文字表示Application.StatusBar = 计算中 双击单元格内容变换Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel
4、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 文件夹选择框方法1Set objShell = CreateObject(Shell.Application)Set objFolder = objShell.BrowseForFolder(0, 文件, 0, 0)If Not objFol
5、der 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
6、.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 folderEnd If 文件选择框方法 Public Function ChooseOneFile(Optional TitleStr As String = Please choose a file, Optional TypesDec As String
7、= *.*, 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 .Allow
8、MultiSelect = 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 endSet CurrentCell
9、 = 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).CellsIf Abs(c.Value) 0.01 Then c.Value = 0Next For Each.Next 循环(不知道确切边界),在活动单元格周围的区域内循环For Each c In ActiveCell.CurrentRegion
10、.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).Va
11、lueMyData.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)
12、End Function 由模板sheet拷贝做成一个新的sheetThisWorkbook.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(Sele
13、ction, 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 FunctionE
14、rrHandle: IsWorksheet = FalseEnd Function 向单元格中写入公式Worksheets(Sheet1).Range(D6).Formula = =SUM(D2:D5) 引用命名单元格区域Range(MyBook.xls!MyRange)Range(Report.xlsSheet1!Sales 选定命名的单元格区域Application.Goto Reference:=MyBook.xls!MyRange或者worksheets(sheetname).range(rangename).selectSelection.ClearContents 使用Dictio
15、nary使用Dictionary需要添加参照Microsoft Scripting RuntimeDim dic As New Dictionary dic.Add Table, Cards 前面是 Key 后面是 Valuedic.Add Serial, serialnodic.Add Number, surface MsgBox dic.Item(Table) 由Key取得Valuedic.Exists(Table) 判断某Key是否存在 将EXCEL表格中的两列表格插入到一个Dictionary中函数：在ws工作表中，从iStartRow行开始到没有数据为止，把iKeyCol列和iKey
16、Col右一列插入到一个字典中，并返回字典。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,
17、 iKeyCol + 1).Value End If i = i + 1 Loop Set SetDic = dicEnd Function 判断文件夹或文件是否存在文件夹If Dir(C:aaa, vbDirectory) = Then MkDir C:aaa End If 文件If Dir(C:aaa1.txt) = Then msgbox 文件C:aaa1.txt不存在 end if 一次注释多行 视图-工具栏-编辑 调出编辑工具栏，工具栏上有个“设置注释块” 和 “解除注释快” 打开文件并将文件赋予到第一个参数wb中注意，这里的path是文件的完整路径，包括文件名。Public Fun
18、ction 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 = file
19、Name Then isWbOpened = True Next open file If isWbOpened = False Then Workbooks.Open path End If Set wb = Workbooks(fileName) Exit FunctionErr: OpenWorkBook = FalseEnd Function 打开一个文件，并将文件赋予到wb中，将文件的sheet页赋予到ws中的完整代码。（用到了上面的函数）If OpenWorkBook(wb, path & & filename) = False Then MsgBox open file erro
20、r. GoTo ErrEnd Ifwb.ActivateSet ws = wb.Worksheets(sheetname) 打开一个不知道确切名字的文件（文件名中含有serachname），并将文件赋予到wb中，将文件的sheet页赋予到ws中的完整代码。用到了上上面的函数OpenWorkBookIf OpenCompanyFile(wb, path, searchname) = False Then MsgBox open file error. GoTo ErrEnd Ifwb.ActivateSet ws = wb.Worksheets(sheetname) 直接使用的函数OpenCom
21、panyFileFunction 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
22、 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个子checkbox1checkbox10，还有一个总开关checkbox11，让checkbox11控制110的选择和非选择。Private Sub C
23、heckBox11_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
24、chb.Object.Value = False End If NextEnd IfEnd Sub 修改B6单元格所在的pivot的数据源，并刷新pivotSet pvt = ActiveSheet.Range(B6).PivotTablepvt.ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _SheetName!R4C2:R & lngLastRow & C22, Version:=xlPivotTableVersion10)pvt.PivotCache.Refr
25、esh 将一个图形（比如一个长方形的框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是
26、否被打挑。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 Vari
27、ant 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
28、 单元格为空，取不到值的时候，转化为空字符串。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 0Empty to 0Public Function ChangeEmptyToLong(var As Variant) As Lon
29、gOn 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 Di
30、m 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 生成logSub
31、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 #1End Sub Non-Breaking Space网页空格在VBA中的处理替换字符ChrB(160) & ChrB(0)上述最终解决方法来自于.tw/board/FUM20060608180224R4M/BRD2009031011234606U/2.
32、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 = timeGetTimeD
33、o Until timeGetTime - t = num * 1000DoEventsLoopEnd Sub使用方法:delay 33表示秒数 杀掉某程序执行的所有进程Sub KillWord() Dim Process For Each Process In GetObject(winmgmts:).ExecQuery(select * from Win32_Process where name=WINWORD.EXE) Process.Terminate (0) NextEnd Sub 监视某单元格的变化这里最需要注意的问题就是，如果在这个事件里对单元格进行改变，会继续出发此事件变成死循
34、环。所以要在对单元格进行变化之前加上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 E
35、ach 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 develo
36、per.) 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