excelvba常用代码总结1

1、Excel VBA常用代码总结1改变背景色Range("A1"). = xlNoneColorindex 一览无色 0193S394041424344454647衰4950515253545556改变文字颜色Range("A1"). = 1获取单元格Cells( 1, 2)Range("H7")获取范围Range(Cells( 2, 3), Cells( 4, 5)Range("a1:c3"),用快捷记号引用单元格Worksheets( "Sheet1" ).A1:B5选中某sheetSet N

2、ewSheet = Sheets( "sheetl")选中或激活某单元格木'"Range'对象的的Select方法可以选择一个或多个单元格,而Activate 方法 可以指定某一个单元格为活动单元格.'下面的代码首先选择A1:E10区域,同时激活D4单元格：Range("a1:e10" ).SelectRange("d4:e5" ).Activate'而对于下面的代码：Range( "a1:e10" ).SelectRange( "f11:g15" ).

3、Activate'由于区域A1:E10和F11:G15没有公共区域,将最终选择 F11:G15,并?脱活F11 单元格.电获得文档的路径和文件名'路彳至'名耦'路彳至十名耦'或将 ActiveWorkbook 换成 thisworkbook隐藏文档=False禁止屏幕更新=False禁止显示提示和警告消息=False文件夹做成strPath = "C:temp"MkDir strPath状态栏文字表示="计算中"双击单元格内容变换电Private Sub Worksheet_BeforeDoubleClick( B

4、yVal Target As Range, Cancel As Boolean)If >= 5 And <= 8) ThenIf = ">" Then=""Else=">"End IfCancel = True End If End Sub 电文件夹选择框方法1电Set objShell = CreateObject ("")Set objFolder = (0,"文件、0, 0)If Not objFolder Is NothingThen path= & "&

5、quot; end ifSet objFolder = NothingSet objShell = Nothing电文件夹选择框方法 2 (推荐) 电Public Function ChooseFolder() As StringDim dlgOpen As FileDialogSet dlgOpen = (msoFileDialogFolderPicker)With dlgOpen .InitialFileName = &""If .Show = - 1 ThenChooseFolder = .SelectedItems(1)End IfEnd WithSet d

6、lgOpen = NothingEnd Function'使用方法例：Dim path As Stringpath = ChooseFolder()If path <> "" Then MsgBox"open folder"End If 电 文件选择框方法"PleaseExten AsPublic Function ChooseOneFile( Optional TitleStr As String choose a file" , Optional TypesDec As String = "*.*&q

7、uot; , Optional String = "*.*" ) As StringDim dlgOpen As FileDialogSet dlgOpen = (msoFileDialogFilePicker)With dlgOpen.Title = TitleStr .TypesDec, Exten.AllowMultiSelect =False.InitialFileName =If .Show = - 1 Then '.AllowMultiSelect = True 'For Each vrtSelectedItem In .SelectedItem

8、s 'MsgBox "Path name: " & vrtSelectedItem 'Next vrtSelectedItemChooseOneFile = .SelectedItems(1)End IfEnd WithSet dlgOpen = NothingEnd Function电某列到关键字为止循环方法1(假设关键字是end)Set CurrentCell = Range( "A1")Do While <> "end"Set CurrentCell = (1, 0)Loop某列到关键字为止循

9、环方法2(假设关键字是空字符串)i = StartRowDo While Cells(i, 1) <>i = i +1Loop"For Each.Next循环(知道确切边界)For Each c In Worksheets( "Sheetl" ).Range( "A1:D10" ).CellsIf Abs < Then = 0Next"For Each.Next循环(不知道确切边界),在活动单元格周围的区域内循环For Each c In If Abs < Then = 0Next某列有数据的最末行的行数的取得

10、(中间不能有空行)lonRow=1Do While Trim (Cells(lonRow, 2 ).Value) <>""lonRow = lonRow +1LooplonRow11 = lonRow11 - 1A列有数据的最末行的行数的取得另一种方法Range(" A65536").End(xlUp).Row将文字复制到剪贴板Dim MyData As DataObjectSet MyData = NewDataObjectRange("H7").Value取得路径中的文件名Private Function GetFil

11、eName( ByVal s As String )Dim sname() As Stringsname = Split (s, "")GetFileName = sname( UBoundsname)End Function取得路径中的路径名Private Function GetPathName(ByVal s As String )intFileNameStart = InStrRev (s, "")GetPathName = Mid(s, 1, intFileNameStart)End Function由模板sheet拷贝做成一个新的 sheet

12、("template" ).Copy After:=Set doc_s ="newsheetname" & Format(Now, "yyyyMMddhhmmsS选中当列的最后一个有内容的单元格(中间不能有空行)'删除B3开始到B列最后一个有内容的单元格为止的所有内容Range("B3").SelectRange(Selection, (xlDown).Select常量定义Private Const StartRowAs Integer = 3判断sheet是否存在Private Function IsWor

13、ksheet( ByVal strSeetName As String ) As BooleanOn Error GoToErrHandleDim blnRet As BooleanblnRet = IsNull(Worksheets(strSeetName)IsWorksheet = TrueExit FunctionErrHandle: IsWorksheet = FalseEnd Function电向单元格中写入公式Worksheets( "Sheet1" ).Range( "D6").Formula = "=SUM(D2:D5)引用命名

14、单元格区域Range("!MyRange")Range("Sheet1!Sales"选定命名的单元格区域Reference:= "!MyRange"或者worksheets( "sheetname" ).range( "rangename").select使用 Dictionary电'使用 Dictionary 需要添加参照 Microsoft Scripting RuntimeDim dic As NewDictionary"Table" , "Cards

15、" '前面是 Key 后面是 Value"Serial" , "serialno""Number", "surface"MsgBox( "Table")'由 Key取彳# Value("Table")'判断某Key是否存在电将EXCE品格中的两列表格插入到一个Dictionary 中把iKeyCol列和As Integer )'函数：在ws工作表中,从iStartRow行开始到没有数据为止, iKeyCol右一列插入到一个字典中,并返

16、回字典.Public Function SetDic(ws As Worksheet, iStartRow, iKeyColAs DictionaryDim dic As NewDictionaryDim i As Integeri = iStartRowDo Until (i, iRuleCol).Value =""If Not (i, iKeyCol).Value)Then(i, iKeyCol).Value, (i, iKeyCol +1).ValueEnd Ifi = i +1LoopSet SetDic = dicEnd Function电判断文件夹或文件是否存在

17、电'文件夹If Dir ("C:aaa" , vbDirectory) ="" ThenMkDir "C:aaa"End If文件If Dir ("C:aaa" ) = "" Thenmsgbox "文件 不存在"end if电一次注释多行视图一工具栏一编辑调出编辑工具栏,工具栏上有个“设置注释块和“解除注释快翻开文件并将文件赋予到第一个参数wb中注意,这里的path是文件的完整路径,包括文件名.Public Function OpenWorkBook(wbAs Wo

18、rkbook, path As String ) As BooleanOn Error GoToErrOpenWorkBook = TrueDim isWbOpened As BooleanisWbOpened = FalseDim fileName As StringfileName = GetFileName(path)'check file is opened or eitherDim wbTemp As WorkbookFor Each wbTemp In WorkbooksIf = fileName Then isWbOpened = TrueNext'open fi

19、leIf isWbOpened = False ThenpathEnd IfSet wb = Workbooks(fileName)Exit FunctionErr:OpenWorkBook = FalseEnd Function翻开一个文件,并将文件赋予到 wb中,将文件的sheet页赋予到ws中的完整代码.(用到了上面的函数)'If OpenWorkBook(wb, path & "" & "filename") = False ThenMsgBox"open file error."GoToErrEnd

20、IfSet ws = ( "sheetname")翻开一个不知道确切名字的文件(文件名中含有serachname),并将文件赋予到 wb中,将文件的sheet页赋予到ws中的完整代码.电'用到了上上面的函数 OpenWorkBook'If OpenCompanyFile(wb, path, "searchname") = False ThenMsgBox"open file error."GoToErrSet ws = ( "sheetname")'直接使用的函数OpenCompanyFil

21、eFunction OpenCompanyFile(wbComAs Workbook, strPath As String , strFileName As String ) As BooleanDim fs As Variantfs = Dir (strPath &"*.xls") 'seach filesOpenCompanyFile = FalseDo While fs <> ""If InStr (1, fs, strFileName) >0 Then 'file name matchIf OpenWor

22、kBook(wbCom, strPath & "" & fs) = False Then 'open fileOpenCompanyFile =FalseExit DoElseOpenCompanyFile =TrueExit DoEnd Iffs = DirLoopEnd Function电数字转字母(如1转成A, 2转成B)和字母转数字Chr(i + 64)比方i=1的时候,Chr(i + 64)=AAsc(i -64)比方i=A的时候,Asc(i -64)=1chec复选框总开关实现.假设有10个子checkbox1checkbox10 ,还有

23、一个总开关kbox11 ,让checkbox11限制110的选择和非选择.电Private Sub 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" ThenFalseNextE

24、nd IfEnd Sub电修改B6单元格所在的pivot的数据源,并刷新 pivotSet pvt = ( "B6").PivotTableSourceData:= _"SheetName!R4c2:R" & IngLastRow & "C22",Version:=xlPivotTableVersion10)将一个图形(比方一个长方形的框"Rectangle 2")移动到与某个单元格对齐.=True"Rectangle 2" ).Select"Rectangle 2&q

25、uot; ).Top = ( "T5" ).Top"Rectangle 2" ).Left = ("T5" ).Left=False遍历控件.比方遍历所有的checkbox是否被打挑.If ( "CheckBox" & i). = True ThenflgChecked =Trueend if 得到今天的日期 dateNow = (Now(), "YYYY/MM/DD)"在某个sheet页中查找某个关键字 '*'Search keyword from a workshee

26、t(not workbook!)、*Public Function SearchKeyWord(ws As Worksheet, keyword As String ) As BooleanDim var1 As VariantSet var1 = After:=ActiveCell, LookIn:=xlFormulas, LookAt _ :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,MatchCase:= _False , MatchByte:= False , SearchFormat:= False)If var1

27、Is Nothing ThenSearchKeyWord =FalseElseSearchKeyWord =TrueEnd IfEnd Function单元格为空,取不到值的时候,转化为空字符串.电Empty to ""*'Empty to ""*Public Function ChangeEmptyToString(var As Variant) As StringOn Error GoToErrChangeEmptyToString =CStr(var)Exit FunctionErr:ChangeEmptyToString =End Fun

28、ction电单元格为空,取不到值的时候,转化为0.Empty to 0电、*'Empty to 0(*Public Function ChangeEmptyToLong(var As Variant) As LongOn Error GoToErrChangeEmptyToLong = CLng(var)Exit FunctionErr:ChangeEmptyToLong = 0End Function电找到某个sheet页中使用的最末行遍历文件夹下的所有文件(自定义文件夹和后缀名),并返回文件列表字典电Function SetFilesToDic( ByVal path As Str

29、ing , ByVal extension As String )As DictionaryDim MyFile As StringDim s As StringDim count As IntegerDim dic As NewDictionaryIf Right (path, 1) <> "" Thenpath = path &""MyFile = Dir (path & "*." & extension)count =1Do While MyFile <> ""

30、'If MyFile = "" Then' Exit Do'End Ifcount, MyFilecount = count +1MyFile = DirLoopSet SetFilesToDic = dic'sEnd Function电生成log电Sub txtPrint(ByVal txt$, Optional myPath$ ="")'第 2 参数可以指定保存txt文件路径If myPath = "" Then myPath = & ""Open myPath

31、For Append As # 1Print #1, txtClose #1End Sub电&nbsp; Non-Breaking Space 网页空格在 VBA中的处理电替换字符MidBChrB(160) & ChrB( 0)上述最终解决方法来自于 Sdany用户是通过如下思路找到解决方法的和 AscB):Dim I As IntegerFor I =1 To LenB(Cells( 1, 1)AscB(MidB(Cells( 1, 1), I, 1)Next电延时电这段代码在Excel VBA和VB里都可以用I *VB延时函数定义 *声明Private Declare Function timeGetTime Lib "" () 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 ProcessFor Each Proces