Excel VBA常用代码总结1

Excel VBA常用代码总结1

改变背景色

Range("A1").ndex = xlNone

ColorIndex一览





改变文字颜色

获取单元格

Range("A1").ndex = 1

Cells(1, 2)

Range("H7")



获取范围

Range(Cells(2, 3), Cells(4, 5))

Range("a1:c3")

'用快捷记号引用单元格

Worksheets("Sheet1").[A1:B5]



选中某sheet

SetNewSheet = Sheets("sheet1")



选中或激活某单元格

'“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单元格。



获得文档的路径和文件名

'路徑

'名稱

me '路徑＋名稱

'或将ActiveWorkbook换成thisworkbook









隐藏文档

禁止屏幕更新

禁止显示提示和警告消息

文件夹做成

e = False

Updating = False

yAlerts = False

strPath = "C:temp"

MkDirstrPath





状态栏文字表示

双击单元格内容变换

Bar = "计算中"

PrivateSubWorksheet_BeforeDoubleClick(ByVal Target As Range, Cancel

AsBoolean)

If (>= <= 8) Then

= "●"Then

= ""

Else

= "●"

EndIf

Cancel = True

EndIf

End Sub



文件夹选择框方法1

SetobjShell = CreateObject("ation")

SetobjFolder = ForFolder(0, "文件", 0, 0)

IfNotobjFolderIsNothing

Then path= &""

endif

SetobjFolder = Nothing

SetobjShell = Nothing



文件夹选择框方法2（推荐）

PublicFunctionChooseFolder() AsString

DimdlgOpenAsFileDialog

SetdlgOpen = alog(msoFileDialogFolderPicker)

WithdlgOpen

.InitialFileName = &""

If .Show = -1Then

ChooseFolder = .SelectedItems(1)

EndIf

EndWith

SetdlgOpen = Nothing

End Function

'使用方法例：

Dim path AsString

path = ChooseFolder()

If path <>""Then

MsgBox"open folder"

EndIf



文件选择框方法

PublicFunctionChooseOneFile(OptionalTitleStrAsString = "Please choose a

file", OptionalTypesDecAsString = "*.*", OptionalExtenAsString = "*.*")

AsString

DimdlgOpenAsFileDialog

SetdlgOpen = alog(msoFileDialogFilePicker)

WithdlgOpen

.Title = TitleStr

.

.esDec, Exten

.AllowMultiSelect = False

.InitialFileName =

If .Show = -1Then

' .AllowMultiSelect = True

' For Each vrtSelectedItemIn .SelectedItems

' MsgBox "Path name: " &vrtSelectedItem

' Next vrtSelectedItem

ChooseOneFile = .SelectedItems(1)

EndIf

EndWith

SetdlgOpen = Nothing

End Function



某列到关键字为止循环方法1(假设关键字是end)

SetCurrentCell = Range("A1")

<>"end"

„„

SetCurrentCell = (1, 0)

Loop



某列到关键字为止循环方法2(假设关键字是空字符串)

i = StartRow

DoWhileCells(i, 1) <>""

„„

i = i + 1

Loop



"Next 循环(知道确切边界)

ForEach c InWorksheets("Sheet1").Range("A1:D10").Cells

IfAbs() < = 0

Next



"Next 循环(不知道确切边界),在活动单元格周围的区域内循环

ForEach c

IfAbs() < = 0

Next



某列有数据的最末行的行数的取得(中间不能有空行)

lonRow=1

DoWhileTrim(Cells(lonRow, ２).Value) <>""

lonRow = lonRow + 1

Loop

lonRow11 = lonRow11 - 1





A列有数据的最末行的行数的取得另一种方法

将文字复制到剪贴板

Range("Ａ65536").End(xlUp).Row

DimMyDataAsDataObject

SetMyData = NewDataObject

tRange("H7").Value

lipboard



取得路径中的文件名

PrivateFunctionGetFileName(ByVal s AsString)

Dimsname() AsString

sname = Split(s, "")

GetFileName = sname(UBound(sname))

End Function



取得路径中的路径名

PrivateFunctionGetPathName(ByVal s AsString)

intFileNameStart = InStrRev(s, "")

GetPathName = Mid(s, 1, intFileNameStart)

End Function



由模板sheet拷贝做成一个新的sheet

eets("template").Copy

After:=eets()

Setdoc_s = eets()

doc_ = "newsheetname"&Format(Now, "yyyyMMddhhmmss")



选中当列的最后一个有内容的单元格(中间不能有空行)

'删除B3开始到B列最后一个有内容的单元格为止的所有内容

Range("B3").Select

Range(Selection, (xlDown)).Select

ontents





常量定义

判断sheet是否存在

PrivateConstStartRowAsInteger = 3

PrivateFunctionIsWorksheet(ByValstrSeetNameAsString) AsBoolean

OnErrorGoToErrHandle

DimblnRetAsBoolean

blnRet = IsNull(Worksheets(strSeetName))

IsWorksheet = True

Exit Function

ErrHandle:

IsWorksheet = False

End Function





向单元格中写入公式

引用命名单元格区域

Worksheets("Sheet1").Range("D6").Formula = "=SUM(D2:D5)"

Range("!MyRange")

Range("[]Sheet1!Sales"



选定命名的单元格区域

Reference:="!MyRange"

'或者

worksheets("sheetname").range("rangename").select

ontents



使用Dictionary

'使用Dictionary需要添加参照Microsoft Scripting Runtime

DimdicAsNew Dictionary

"Table", "Cards"'前面是 Key 后面是 Value

"Serial", "serialno"

"Number", "surface"

("Table") '由Key取得Value

("Table") '判断某Key是否存在



将EXCEL表格中的两列表格插入到一个Dictionary中

'函数：在ws工作表中，从iStartRow行开始到没有数据为止，把iKeyCol列和iKeyCol右一列插入到一个字典中，并返回字典。

PublicFunctionSetDic(wsAs Worksheet, iStartRow, iKeyColAsInteger) As

Dictionary

DimdicAsNew Dictionary

Dim i AsInteger

i = iStartRow

(i, iRuleCol).Value = ""

((i, iKeyCol).Value) Then

(i, iKeyCol).Value, (i, iKeyCol + 1).Value

EndIf

i = i + 1

Loop

SetSetDic = dic

End Function



判断文件夹或文件是否存在

'文件夹

IfDir("C:aaa", vbDirectory) = ""Then

MkDir"C:aaa"

EndIf

'文件

IfDir("C:") = ""Then

msgbox"文件C:不存在"

endif



一次注释多行

视图---工具栏---编辑 调出编辑工具栏，工具栏上有个“设置注释块” 和 “解除注释快”



打开文件并将文件赋予到第一个参数wb中

'注意，这里的path是文件的完整路径，包括文件名。

PublicFunctionOpenWorkBook(wbAs Workbook, path AsString) AsBoolean

OnErrorGoTo Err

OpenWorkBook = True

DimisWbOpenedAsBoolean

isWbOpened = False

DimfileNameAsString

fileName = GetFileName(path)

'check file is opened or either

DimwbTempAs Workbook

ForEachwbTempIn Workbooks

= fileNameThenisWbOpened = True

Next

'open file

IfisWbOpened = FalseThen

path

EndIf

Setwb = Workbooks(fileName)

Exit Function

Err:

OpenWorkBook = False

End Function



打开一个文件，并将文件赋予到wb中，将文件的sheet页赋予到ws中的完整代码。（用到了上面的函数）

'If OpenWorkBook(wb, path & "" & "filename") = False Then

MsgBox"open file error."

GoTo Err

EndIf

te

Setws = eets("sheetname")



打开一个不知道确切名字的文件（文件名中含有serachname），并将文件赋予到wb中，将文件的sheet页赋予到ws中的完整代码。

'用到了上上面的函数OpenWorkBook

'If OpenCompanyFile(wb, path, "searchname") = False Then

MsgBox"open file error."

GoTo Err

EndIf

te

Setws = eets("sheetname")

'直接使用的函数OpenCompanyFile

FunctionOpenCompanyFile(wbComAs Workbook, strPathAsString,

strFileNameAsString) AsBoolean

DimfsAs Variant

fs = Dir(strPath&"*.xls") 'seach files

OpenCompanyFile = False

DoWhilefs<>""

IfInStr(1, fs, strFileName) >0Then'file name match

IfOpenWorkBook(wbCom, strPath&""&fs) = FalseThen'open file

OpenCompanyFile = False

ExitDo

Else

OpenCompanyFile = True

ExitDo

EndIf

EndIf

fs = Dir

Loop

End Function



数字转字母（如1转成A，2转成B）和字母转数字

Chr(i + 64)

比如i=1的时候，Chr(i + 64)=A

Asc(i - 64)

比如i=A的时候，Asc(i - 64)=1



复选框总开关实现。假如有10个子checkbox1~checkbox10，还有一个总开关checkbox11，让checkbox11控制1~10的选择和非选择。

PrivateSub CheckBox11_Click()

DimchbAs Variant

= TrueThen

ects

Like "CheckBox*"<>"CheckBox11"Then

= True

EndIf

Next

Else

ects

Like "CheckBox*"<>"CheckBox11"Then

= False

EndIf

Next

EndIf

End Sub



修改B6单元格所在的pivot的数据源，并刷新pivot

Setpvt = ("B6").PivotTable

(SourceType:=xlDatabase, SourceData:= _

"SheetName!R4C2:R"&lngLastRow&"C22", Version:=xlPivotTableVersion10)

h



将一个图形（比如一个长方形的框"Rectangle 2"）移动到与某个单元格对齐。

te

Updating = True

(Array("Rectangle 2")).Select

(Array("Rectangle 2")).Top = ("T5").Top

(Array("Rectangle 2")).Left = ("T5").Left

Updating = False



遍历控件。比如遍历所有的checkbox是否被打挑。

ects("CheckBox"& i). = TrueThen

flgChecked = True

endif



得到今天的日期

dateNow = (Now(), "YYYY/MM/DD")



在某个sheet页中查找某个关键字

'****************************************************

'Search keyword from a worksheet(not workbook!)

'****************************************************

PublicFunctionSearchKeyWord(wsAs Worksheet, keyword AsString) AsBoolean

Dim var1 As Variant

Set var1 = (What:=keyword, After:=ActiveCell,

LookIn:=xlFormulas, LookAt _

:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _

False, MatchByte:=False, SearchFormat:=False)

If var1 IsNothingThen

SearchKeyWord = False

Else

SearchKeyWord = True

EndIf

End Function



单元格为空，取不到值的时候，转化为空字符串。Empty to ""

'****************************************************

'Empty to ""

'****************************************************

PublicFunctionChangeEmptyToString(varAs Variant) AsString

OnErrorGoTo Err

ChangeEmptyToString = CStr(var)

Exit Function

Err:

ChangeEmptyToString = ""

End Function



单元格为空，取不到值的时候，转化为0。Empty to 0

'****************************************************

'Empty to 0

'****************************************************

PublicFunctionChangeEmptyToLong(varAs Variant) AsLong

OnErrorGoTo Err

ChangeEmptyToLong = CLng(var)

Exit Function

Err:

ChangeEmptyToLong = 0

End Function





找到某个sheet页中使用的最末行

遍历文件夹下的所有文件（自定义文件夹和后缀名），并返回文件列表字典

FunctionSetFilesToDic(ByVal path AsString, ByVal extension AsString) As

Dictionary

DimMyFileAsString

Dim s AsString

Dim count AsInteger

DimdicAsNew Dictionary

IfRight(path, 1) <>""Then

path = path &""

EndIf

MyFile = Dir(path &"*."& extension)

count = 1

DoWhileMyFile<>""

' If MyFile = "" Then

' Exit Do

' End If

count, MyFile

count = count + 1

MyFile = Dir

Loop

SetSetFilesToDic = dic

' s

End Function



生成log

SubtxtPrint(ByVal txt$, OptionalmyPath$ = "") '第2参数可以指定保存txt文件路径

IfmyPath = ""ThenmyPath = &""

Open myPathFor Append As #1

Print #1, txt

Close #1

End Sub



  [Non-Breaking Space]网页空格在VBA中的处理

替换字符

ChrB(160) &ChrB(0)

上述最终解决方法来自于/board/FUM24R4M/BRD2606U/

Sdany用户是通过如下思路找到解决方法的（用MidB和AscB）：

Dim I AsInteger

For I = 1ToLenB(Cells(1, 1))

scB(MidB(Cells(1, 1), I, 1))

Next



延时

这段代码在Excel VBA 和VB里都可以用

'***********VB 延时函数定义*************************************

'声明

PrivateDeclareFunctiontimeGetTimeLib"" () AsLong

'延时

PublicSubDelay(ByValnumAsInteger)

Dim t AsLong

t = timeGetTime

DoUntiltimeGetTime - t >= num * 1000

DoEvents

Loop

End Sub

'***************************************************************

使用方法:

delay 3'3表示秒数



杀掉某程序执行的所有进程

SubKillWord()

Dim Process

ForEach Process InGetObject("winmgmts:").ExecQuery("select * from

Win32_Process where name=''")

ate (0)

Next

End Sub



监视某单元格的变化

这里最需要注意的问题就是，如果在这个事件里对单元格进行改变，会继续出发此事件变成死循环。

所以要在对单元格进行变化之前加上Events = False，变完之后再改为True。

PrivateSubWorksheet_Change(ByVal Target As Range)

OnErrorGoTo Err

Events = False

Dim c

SetdicKtoW = SetDic(("reference"), 3, 1, 2)

SetdicKtoX = SetDic(("reference"), 3, 1, 3)

ForEach c In Target

= 11Then

'

("W"&).Value = GetDic(dicKtoW, )

("X"&).Value = GetDic(dicKtoX, )

EndIf

Next

SetdicKtoW = Nothing

SetdicKtoX = Nothing

Events = True

Exit Sub

Err:

MsgBox ("Error!Please contact macro developer.")

Events = True

End Sub



On Error的用法

1.一般用法

OnErrorGoTo Label

各种代码

exit sub

Label:

ption

其他错误处理

2.对于某段代码单独处理

OnErrorResumeNext

需要监视的代码

<>0Then

ption

EndIf

OnErrorGoTo0

3.上述两种的结合

OnErrorResumeNext

需要监视的代码

<>0Then

ption

Goto Label

EndIf

OnErrorGoTo0

exit sub

Label:

其他错误处理



EXCEL的分组功能和展开收缩功能

'将A列到C列进行分组

Range("A:C").

'默认情况下，分组后的A到C列会是展开状态，如果想让A到C列收缩

Range("A:C").=True