Excel VBA常用代码总结1.doc

《Excel VBA常用代码总结1.doc》由会员分享，可在线阅读，更多相关《Excel VBA常用代码总结1.doc（12页珍藏版）》请在淘文阁 - 分享文档赚钱的网站上搜索。

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.Selec

2、t 选中或激活某单元格“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名稱Ac

3、tiveWorkbook.FullName 路徑名稱或将ActiveWorkbook换成thisworkbook 隐藏文档Application.Visible = False 禁止屏幕更新Application.ScreenUpdating = False 禁止显示提示和警告消息Application.DisplayAlerts = False 文件夹做成strPath = C:tempMkDir strPath 状态栏文字表示Application.StatusBar = 计算中 双击单元格内容变换Private Sub Worksheet_BeforeDoubleClick(ByVal

4、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 文件夹选择框方法1Set objShell = CreateObject(Shell.Application)Set objFolder = objShell.BrowseForFolder(0

5、, 文件, 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 =

6、 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 folderEnd If 文件选择框方法 Public Function ChooseOneFile(Optional TitleStr As String = Please choose a file, Opti

7、onal 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 I

8、f .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.

9、Value endSet 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).CellsIf Abs(c.Value) 0.01 Then c.Value = 0Next For Each.Next 循环(不知道确切边界),在活动单元格周围的区域内循环For Each c In

10、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 DataObjectMyD

11、ata.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

12、(s, 1, intFileNameStart)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列最后一个有内容的单元格为止的所有内容Ra

13、nge(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) IsWorkshe

14、et = True Exit FunctionErrHandle: 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).selectSelectio

15、n.ClearContents 使用Dictionary使用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行

16、开始到没有数据为止，把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, iKe

17、yCol).Value, ws.Cells(i, 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是

18、文件的完整路径，包括文件名。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 Workboo

19、ks If wbTemp.Name = fileName 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 Th

20、en MsgBox open file error. 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(s

21、heetname) 直接使用的函数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, strP

22、ath & & 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个子checkbox1checkbox10，还有一个总开关checkbox11，让checkbox11控制

23、110的选择和非选择。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 c

24、hb.Name CheckBox11 Then 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:=xlPivotTableVersi

25、on10)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 = Fal

26、se 遍历控件。比如遍历所有的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

27、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 =

28、 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 0Empty to 0Public Function ChangeEmptyToLon

29、g(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 S

30、tring 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

31、 sEnd Function 生成logSub 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

32、/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

33、 As Longt = timeGetTimeDo 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(re

35、ference), 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!Ple

36、ase 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