Excel VBA常用代码总结1(35页).doc

-改变背景色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· 选中某sheetSet 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· 文件夹选择框方法1Set 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").CellsIf 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拷贝做成一个新的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(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.xlsSheet1!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:aaa1.txt") = "" Then msgbox "文件C:aaa1.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个子checkbox1checkbox10，还有一个总开关checkbox11，让checkbox11控制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 chb.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:=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· 生成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· &nbsp; Non-Breaking Space网页空格在VBA中的处理替换字符ChrB(160) & ChrB(0)上述最终解决方法来自于.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第 37 页-