excelvba常用代码总结1

1、Excel VBA常用代码总结1改变背景色Ran ge(A1). = xlN oneColorl ndex 览Ran ge(A1). =1获取单元格Cells( 1, 2)Ran ge(H7)获取范围Range(Cells( 2, 3), Cells( 4, 5)Range(a1:c3)用快捷记号引用单元格Worksheets( Sheet1 ).A1:B5无色01920白色21 224725,26改变文字颜色52338394041424344454647卿4950515253545556选中某 sheetSet NewSheet = Sheets( sheetl)选中或激活某单元格“Rang

2、d对象的的 Select 方法可以选择一个或多个单元格，而 Activate 方法 可以指定某一个单元格为活动单元格。下面的代码首先选择 A1:E10 区域，同时激活 D4 单元格：Range(a1:e10 ).SelectRange(d4:e5 .Activate而对于下面的代码：Range(a1:e10 ).SelectRange(f11:g15 .Activate由于区域 A1:E10 和 F11:G15 没有公共区域，将最终选择 F11:G15，并激活 F11 单元格。获得文档的路径和文件名路徑名稱路徑+名稱或将 ActiveWorkbook 换成 thisworkbook隐藏文档=F

3、alse禁止屏幕更新=False选中某 sheet禁止显示提示和警告消息False文件夹做成strPath = C:tempMkDir strPath状态栏文字表示=计算中双击单元格内容变换Private Sub Worksheet_BeforeDoubleClick( ByVai Target As Range, Cancel AsBoolea n)If =5 And = 8) ThenIf = Then_IlliElse= End IfCan cel =TrueEnd IfEnd Sub文件夹选择框方法 1Set objShell = CreateObject ()Set objFolde

4、r = (0,文件,0, 0)If Not objFolder Is NothingThen path= &end ifSet objFolder = Noth ingSet objShell = Nothi ng文件夹选择框方法 2 (推荐)Public Function ChooseFolder() As StringDim dlgOpe nAs FileDialogSet dlgOpe n = (msoFileDialogFolderPicker)With dlgOpe n.In itialFileName = &If .Show = - 1 ThenChooseFold

5、er = .SelectedItems(1)End IfEnd WithSet dlgOpe n = Noth ingEnd Function使用方法例：Dim path As Stringpath = ChooseFolder()If path ThenMsgBoxopen folderEnd If文件选择框方法Public Function ChooseOneFile( Optional TitleStr As String choose afile , Optional TypesDec As String = *.* , Optional String = *.* ) AsString

6、Dim dlgOpe nAs FileDialogSet dlgOpe n = (msoFileDialogFilePicker)PleaseExte n AsDo While Cells(i, 1) IlliWith dlgOpe n.Title = TitleStr.TypesDec, Exte n.AIIowMultiSelect =Falsen itialFileName =If .Show = - 1 Then.AllowMultiSelect = TrueFor Each vrtSelectedItem In .SelectedltemsMsgBox P ath name: &am

7、p; vrtSelectedItemNext vrtSelectedItemChoose On eFile = .Selectedltems(1)End IfEnd WithSet dlgOpe n = Noth ingEnd Function某列到关键字为止循环方法1(假设关键字是 en d)Set Curre ntCell = Ra nge( A1)Do While endSet Curre ntCell = (1,0)Loop某列到关键字为止循环方法2(假设关键字是空字符串)i = StartRowi = i +1LoopFor Each.Next循环(知道确切边界)For Each c

8、 In Worksheets( Sheetl ).Range( A1:D10 ).CellsIf Abs Then = 0NextFor Each.Next 循环(不知道确切边界),在活动单元格周围的区域内循环For Each c In If Abs Then = 0Next某列有数据的最末行的行数的取得(中间不能有空行)Ion Row=1Do While Trim (Cells(lonRow,2).Value) Ion Row = Ion Row +1LoopIon Row11 = Ion Row11 - 1A 列有数据的最末行的行数的取得另一种方法Range(A65536).End(xlU

9、p).Row将文字复制到剪贴板Dim MyData As DataObjectSet MyData = NewDataObjectRan ge(H7).Value取得路径中的文件名Private Function GetFileName( ByVal s As String )Dim sname() As Stringsname =Split (s, )GetFileName = sn ame( UBo undsn ame)End Fun cti on取得路径中的路径名Private Function GetPathName(ByVal s As String )intFileNameStar

10、t =InStrRev (s, )GetPathName = Mid(s, 1, i ntFileNameStart)End Fun cti on由模板 sheet 拷贝做成一个新的 sheet(template ).Copy After:=Set doc_s =newsheetname & Format(Now, yyyyMMddhhmmss选中当列的最后一个有内容的单元格(中间不能有空行)删除 B3 开始到 B 列最后一个有内容的单元格为止的所有内容Ran ge(B3 ).SelectRan ge(Select ion, (xlDow n).Select常量定义Private Co

11、nst StartRow判断 sheet 是否存在As Integer =3Private Function lsWorksheet( ByVal strSeetName As String ) As BooleanOn Error GoToErrHandleDim blnRet As Booleanbln Ret = IsNull(Worksheets(strSeetName)IsWorksheet = TrueExit FunctionErrHa ndle:IsWorksheet = FalseEnd Fun cti on向单元格中写入公式Worksheets( Sheetl ).Rang

12、e( D6).Formula =二SUM(D2:D5)引用命名单元格区域Ran ge(!MyRa nge)Ra nge(Sheet1!Sales选定命名的单元格区域Refere nce:= !MyRa nge或者worksheets( sheetname).range( rangename).select使用 Dictionary使用 Dictionary 需要添加参照 Microsoft Scripting RuntimeDim dic As NewDictionaryTable , Cards 前面是 Key 后面是 ValueSerial , serialnoNumber, surfac

13、eMsgBox( Table)由 Key 取得 Value(Table)判断某 Key 是否存在将 EXCEL 表格中的两列表格插入到一个Dictionary 中函数：在 ws 工作表中，从 iStartRow 行开始到没有数据为止，iKeyCol 右一列插入到一个字典中，并返回字典。Public Function SetDic(ws As Worksheet, iStartRow, iKeyCol AsDictio nary把 iKeyCol 列和As Integer )Dim dic As NewDictionaryDim i As Integeri = iStartRowDo Un ti

14、l (i, iRuleCol).Value =If Not (i, iKeyCol).Value) Then(i, iKeyCol).Value, (i, iKeyCol +End If1).Valuei = i +LoopSet SetDic = dicEnd Fun cti on判断文件夹或文件是否存在文件夹If Dir (C:aaa , vbDirectory) = ThenMkDir C:aaaEnd If文件If Dir (C:aaa ) = Thenmsgbox 文件不存在end if一次注释多行视图-工具栏-编辑调出编辑工具栏，工具栏上有个“设置注释块”和“解除注释快”打开文件并

15、将文件赋予到第一个参数wb 中注意，这里的 path 是文件的完整路径，包括文件名。Public Function OpenWorkBook(wbAs Workbook, path As String ) As BooleanOn Error GoToErrOpen WorkBook = TrueDim isWbOpened As BooleanisWbOpe ned = FalseDim fileName As StringfileName = GetFileName(path)check file is opened or eitherDim wbTemp As WorkbookFor E

16、ach wbTemp In WorkbooksIf = fileNameThe n isWbOpe ned = TrueNextope n fileIf isWbOpened = False ThenpathEnd IfSet wb = Workbooks(fileName)Exit FunctionErr:Ope nWorkBook = FalseEnd Fun cti on打开一个文件，并将文件赋予到 wb 中，将文件的 sheet 页赋予到 ws 中的完整代码。 (用到了上面的函数)If OpenWorkBook(wb, path & & filename) = Fals

17、e ThenMsgBoxope n file error.GoToErrEnd IfSet ws = ( sheetname)打开一个不知道确切名字的文件(文件名中含有serach name),并将文件赋予到 wb 中，将文件的 sheet 页赋予到 ws 中的完整代码。0用到了上上面的函数 OpenWorkBookIf Ope nCompa nyFile(wb, path, search name) = False The nMsgBoxope n file error.GoToErrEnd IfSet ws = ( sheetname)直接使用的函数 OpenCompanyFileFunc

18、tion OpenCompanyFile(wbComAs Workbook, strPath As String , strFileNameAs String ) As BooleanDim fs As Varia ntfs = Dir (strPath &*.xls) seach filesOpen Compa ny File = FalseDo While fs If In Str (1, fs, strFileName) 0 The n file name matchIf OpenWorkBook(wbCom, strPath & & fs) = False Th

19、en ope n fileOpen Compa ny File =Exit DoElseOpen Compa ny File =Exit DoEnd IfFalseTrueEnd Iffs = DirLoopEnd Fun cti on数字转字母(如 1 转成 A, 2 转成 B)和字母转数字Chr(i +64)比如 i=1 的时候，Chr(i +64)=AAsc(i -64)比如 i=A 的时候，Asc(i -64)=1复选框总开关实现。假如有10 个子 checkbox1checkbox10，还有一个总开关kbox11，让 checkbox 控制 110 的选择和非选择。Private S

20、ub CheckBox11_Click()Dim chb As VariantIf = True ThenFor Each chb InIf Like CheckBox* And CheckBox11 Then=TrueEnd IfNextElseFor Each chb InIf Like CheckBox* And CheckBox11 ThenFalsechecEnd IfNextEnd IfEnd Sub修改 B6 单元格所在的 pivot 的数据源，并刷新 pivotSet pvt = ( B6).PivotTableSourceData:= _SheetName!R4C2:R &a

21、mp; In gLastRow & C22,Versi on: =xlPivotTableVersi on 10)将一个图形(比如一个长方形的框Recta ngle 2)移动到与某个单元格对齐。=TrueRectangle 2 ).SelectRectangle 2 ).Top = (T5 ).TopRectangle 2 ).Left = (T5 ).Left=False遍历控件。比如遍历所有的checkbox 是否被打挑。If ( CheckBox & i). = True ThenflgChecked =Trueend if得到今天的日期dateNow = (Now(),

22、 YYYY/MM/DD在某个 sheet 页中查找某个关键字End If*Cha ngeEmptyToStri ng =IlliSearch keyword from a worksheet (not workbook!)*Public Function SearchKeyWord(ws As Worksheet, keyword As String ) AsBoolea nDim varl As Varia ntSet varl = After:=ActiveCell, Lookl n: =xlFormulas, LookAt _:=xlPart, SearchOrder:=xlByRows

23、, SearchDirecti on: =xlNext,MatchCase:= _False , MatchByte:= False , SearchFormat:= False)If varl Is Nothing ThenSearchKeyWord =FalseElseSearchKeyWord =TrueEnd IfEnd Fun cti on单元格为空，取不到值的时候，转化为空字符串。Empty toykkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkEmpty to *Public Function ChangeEmptyToSt

24、ring(var As Variant)As StringOn Error GoToErrCha ngeEmptyToStri ng =CStr(var)Exit FunctionErr:End Fun cti on单元格为空，取不到值的时候，转化为0。Empty to 0*Empty to 0*Public Function ChangeEmptyToLong(var As Variant)As LongOn Error GoToErrChan geEmptyToL ong = CLng(var)Exit FunctionErr:Chan geEmptyToL ong = 0End Fun

25、cti on找到某个 sheet 页中使用的最末行遍历文件夹下的所有文件(自定义文件夹和后缀名)，并返回文件列表字典Function SetFilesToDic( ByVai path As String , ByVai extensionAs Dictio naryDim MyFile As StringDim s As StringDim count As IntegerDim dic As NewDictionaryIf Right (path, 1) Thenpath = path &As String )End IfMyFile = Dir (path & *. &a

26、mp; extension)count =1Do While MyFile If MyFile = The nExit DoEnd Ifcount, MyFilecount = count +1MyFile = DirLoopSet SetFilesToDic = dicsEnd Fun cti on生成 logSub txtPrint( ByVal txt$,Optional myPath$ =)第 2 参数可以指定保存txt 文件路径If myPath = Then myPath = &Ope n myPath For Appe nd As # 1Print # 1, txtClo

27、se #1End Sub  Non-Breaking Space网页空格在 VBA 中的处理替换字符ChrB(160) & ChrB( 0)上述最终解决方法来自于 Sdany 用户是通过如下思路找到解决方法的和 AscB):Dim I As IntegerFor I =1 To Len B(Cells( 1, 1)AscB(MidB(Cells( 1, 1), I, 1)Next延时声明Private Declare Function timeGetTime Lib () As Long延时Public Sub Delay( ByVal num As Integer )Dim t As Long t = timeGetTimeMidB这段代码在 Excel VBA 和 VB 里都可以用*VB延时函数定义*Do Until timeGetTime - t = num *1000DoEve ntsLoopEnd Sub*使用方法：delay 33 表示秒数杀掉某程序执行的所有进程Sub KillWord()Dim ProcessFor Each Pro