VBA代码汇总.docx

1：打开所有隐藏工作表Sub打开所有隐藏工作表()DimiAsIntegerFori=1ToSheets.CountSheets(i).Visible=TrueNextiEndSub2：循环宏Sub循环()AAA=Range(C2)DimiAsLongDimtimesAsLongtimes=AAAtimes代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)Fori=1TotimesCall过滤一行IfRange(完成标志)=完成ThenExitFor假如名为完成标志的命名单元的值等于完成,则退出循环,假如一开始就等于完成,则只执行一次循环就退出IfSheets(传送参数).Range(A&i).Text=完成ThenExitFor假如某列出现完成内容则退出循环NextiEndSub3：录制宏时调用“停止录制”工具栏Sub录制宏时调用停止录制工具栏()Application.CommandBars(StopRecording).Visible=TrueEndSub4：高级筛选5列不重复数据至指定表Sub高级筛选5列不重复数据至Sheet2()Sheets(Sheet2).Range(A1:E65536)=清除Sheet2的A:D列Range(A1:E65536).AdvancedFilterAction:=xlFilterCopy,CopyToRange:=Sheet2.Range(_A1),Unique:=TrueSheet2.Columns(A:E).SortKey1:=Sheet2.Range(A2),Order1:=xlAscending,Header:=xlGuess,_OrderCustom:=1,MatchCase:=False,Orientation:=xlTopToBottom,SortMethod_:=xlPinYinEndSub5：双击单元执行宏(工作表代码)PrivateSubWorksheet_BeforeDoubleClick(ByValTargetAsRange,CancelAsBoolean)IfRange($A$1)=关闭ThenExitSubSelectCaseTarget.AddressCase$A$4Call宏1Cancel=TrueCase$B$4Call宏2Cancel=TrueCase$C$4Call宏3Cancel=TrueCase$E$4Call宏4Cancel=TrueEndSelectEndSub6：双击指定区域单元执行宏(工作表代码)PrivateSubWorksheet_BeforeDoubleClick(ByValTargetAsRange,CancelAsBoolean)IfRange($A$1)=关闭ThenExitSubIfNotApplication.Intersect(Target,Range(A4:A9,C4:C9)IsNothingThenCall打开隐藏表EndSub7：进入单元执行宏(工作表代码)PrivateSubWorksheet_SelectionChange(ByValTargetAsRange)以单元格进入代替按钮对象调用宏IfRange($A$1)=关闭ThenExitSubSelectCaseTarget.AddressCase$A$5单元地址(Target.Address),或命名单元名字(Target.Name)Call宏1Case$B$5Call宏2Case$C$5Call宏3EndSelectEndSub8：进入指定区域单元执行宏(工作表代码)PrivateSubWorksheet_SelectionChange(ByValTargetAsRange)IfRange($A$1)=关闭ThenExitSubIfNotApplication.Intersect(Target,Range(A4:A9,C4:C9)IsNothingThenCall打开隐藏表EndSub9：在多个宏中依次循环执行一个（控件按钮代码）PrivateSubCommandButton1_Click()StaticRunMacroAsIntegerSelectCaseRunMacroCase0宏1RunMacro=1Case1宏2RunMacro=2Case2宏3RunMacro=0EndSelectEndSub10：在两个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）PrivateSubCommandButton1_Click()WithCommandButton1If.Caption=保护工作表ThenCall保护工作表.Caption=取消工作表保护ExitSubEndIfIf.Caption=取消工作表保护ThenCall取消工作表保护.Caption=保护工作表ExitSubEndIfEndWithEndSub11：在三个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）OptionExplicitPrivateSubCommandButton1_Click()WithCommandButton1If.Caption=宏1ThenCall宏1.Caption=宏2ExitSubEndIfIf.Caption=宏2ThenCall宏2.Caption=宏3ExitSubEndIfIf.Caption=宏3ThenCall宏3.Caption=宏1ExitSubEndIfEndWithEndSub12：根据A1单元文本隐藏/显示按钮（控件按钮代码）PrivateSubWorksheet_SelectionChange(ByValTargetAsRange)IfRange(A1)2ThenCommandButton1.Visible=1ElseCommandButton1.Visible=0EndIfEndSubPrivateSubCommandButton1_Click()重排窗口EndSub13：当前单元返回按钮名称（控件按钮代码）PrivateSubCommandButton1_Click()ActiveCell=CommandButton1.CaptionEndSub14：当前单元内容返回到按钮名称（控件按钮代码）PrivateSubCommandButton1_Click()CommandButton1.Caption=ActiveCellEndSub15：奇偶页分别打印Sub奇偶页分别打印()Dimi%,Ps%Ps=ExecuteExcel4Macro(GET.DOCUMENT(50)总页数MsgBox现在打印奇数页,按确定开始.Fori=1ToPsStep2ActiveSheet.PrintOutfrom:=i,To:=iNextiMsgBox现在打印偶数页,按确定开始.Fori=2ToPsStep2ActiveSheet.PrintOutfrom:=i,To:=iNextiEndSub16：自动打印多工作表第一页Sub自动打印多工作表第一页()DimshAsIntegerDimxDimyDimsyDimsyzx=InputBox(请输入起始工作表名字:)sy=InputBox(请输入结束工作表名字:)y=Sheets(x).Indexsyz=Sheets(sy).IndexForsh=yTosyzSheets(sh).SelectSheets(sh).PrintOutfrom:=1,To:=1NextshEndSub17：查找A列文本循环插入分页符Sub循环插入分页符()Selection=Workbooks(临时表).Sheets(表2).Range(A1)调用指定地址内容DimiAsLongDimtimesAsLongtimes=Application.WorksheetFunction.CountIf(Sheet1.Range(a:a),分页)times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)Fori=1TotimesCall插入分页符NextiEndSubSub插入分页符()Cells.Find(What:=分页,After:=ActiveCell,LookIn:=xlValues,LookAt:=_xlPart,SearchOrder:=xlByRows,SearchDirection:=xlNext,MatchCase:=False)_.ActivateActiveWindow.SelectedSheets.HPageBreaks.AddBefore:=ActiveCellEndSubSub取消原分页()Cells.SelectActiveSheet.ResetAllPageBreaksEndSub18：将A列最后数据行以上的所有B列图片大小调整为所在单元大小Sub将A列最后数据行以上的所有B列图片大小调整为所在单元大小()DimPicAsPicture,i&i=A65536.End(xlUp).RowForEachPicInSheet1.PicturesIfNotApplication.Intersect(Pic.TopLeftCell,Range(B1:B&i)IsNothingThenPic.Top=Pic.TopLeftCell.TopPic.Left=Pic.TopLeftCell.LeftPic.Height=Pic.TopLeftCell.HeightPic.Width=Pic.TopLeftCell.WidthEndIfNextEndSub19：返回光标所在行数Sub返回光标所在行数()x=ActiveCell.RowRange(A1)=xEndSub20：在A1返回当前选中单元格数量Sub在A1返回当前选中单元格数量()A1=Selection.CountEndSub21：返回当前工作簿中工作表数量Sub返回当前工作簿中工作表数量()t=Application.Sheets.CountMsgBoxtEndSub93：B列录入数据时在A列返回记录时间（工作表代码）PublicSubWorksheet_Change(ByValTargetAsRange)IfTarget.Column=2ThenTarget.Offset(,-1)=NowEndIfEndSub94：当指定区域修改时在其右侧的2个单元返回当前日期和时间（工作表代码）PublicSubWorksheet_Change(ByValTargetAsRange)IfNotApplication.Intersect(Target,A1:A1000)IsNothingThenIfTarget.Column=1ThenTarget.Offset(,1)=DateTarget.Offset(,2)=TimeEndIfEndIfEndSubPublicSubWorksheet_Change(ByValTargetAsRange)IfNotApplication.Intersect(Target,A1:A1000)IsNothingThenIfTarget.Column=1ThenTarget.Offset(,1)=Format(Now(),yyyy-mm-dd)Target.Offset(,2)=Format(Now(),h:mm:ss)EndIfEndIfEndSub95：指定单元显示光标位置内容（工作表代码）PrivateSubWorksheet_SelectionChange(ByValTAsRange)Sheets(1).Range(A1)=SelectionEndSub96：每编辑一个单元保存文件PrivateSubWorksheet_Change(ByValTargetAsRange)ThisWorkbook.SaveEndSub97：指定允许编辑区域Sub指定允许编辑区域()ActiveSheet.ScrollArea=B8:G15EndSub98：解除允许编辑区域限制Sub解除允许编辑区域限制()ActiveSheet.ScrollArea=EndSub99：删除指定行Sub删除指定行()Workbooks(临时表).Sheets(表2).Range(5:5).DeleteEndSub100：删除A列为指定内容的行Sub删除A列为指定内容的行()Dima,bAsIntegera=Sheet1.a65536.End(xlUp).RowForb=aTo2Step-1IfCells(b,1).Value=删除ThenRows(b).DeleteEndIfNextEndSubExcel VBA常用代码总结1改变背景色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”对象的的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:tempMkDir 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 folderEnd 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 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 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, serialnodic.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中的完整代码。用到了上上面的函数OpenWorkBookIf 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 = Fal