收藏
下载资源下载资源 加入VIP,免费下载

Excel VBA 共五章学习实例第12679章实用VBA源代码.docx

上传人：b****6 文档编号：6836522 上传时间：2023-01-11 格式：DOCX 页数：88 大小：43.68KB
下载 相关 举报
Excel VBA 共五章学习实例第12679章实用VBA源代码.docx_第1页
第1页 / 共88页
Excel VBA 共五章学习实例第12679章实用VBA源代码.docx_第2页
第2页 / 共88页
Excel VBA 共五章学习实例第12679章实用VBA源代码.docx_第3页
第3页 / 共88页
Excel VBA 共五章学习实例第12679章实用VBA源代码.docx_第4页
第4页 / 共88页
Excel VBA 共五章学习实例第12679章实用VBA源代码.docx_第5页
第5页 / 共88页
点击查看更多>>
下载资源
资源描述

Excel VBA 共五章学习实例第12679章实用VBA源代码.docx

《Excel VBA 共五章学习实例第12679章实用VBA源代码.docx》由会员分享，可在线阅读，更多相关《Excel VBA 共五章学习实例第12679章实用VBA源代码.docx（88页珍藏版）》请在冰豆网上搜索。

Excel VBA 共五章学习实例第12679章实用VBA源代码.docx

ExcelVBA共五章学习实例第12679章实用VBA源代码

第1章Range（单元格）对象（范例1~范例17）

第2章Sheet（工作表）对象（范例18~范例37）

第6章控件与用户窗体（范例67~范例112）

第7章使用对话框（范例113~范例118）

第9章文件操作（范例134~范例143）

范例1单元格的引用方法（返回）

使用Range属性引用单元格区域

SubMyRng（）

Range（"A1:

B4,D5:

E8"）.Select

Range（"A1"）.Formula="=Rand（）"

Range（"A1:

B4B2:

C6"）.Value=10

Range（"A1","B4"）.Font.Italic=True

EndSub

使用Cells属性引用单元格区域

SubMyCell（）

DimiAsByte

Fori=1To10

Sheets（"Sheet1"）.Cells（i,1）.Value=i

Next

EndSub

使用快捷记号实现快速输入

SubFastMark（）

[A1]="Excel2007"

EndSub

使用Offset属性返回单元格区域

SubRngOffset（）

Sheets（"Sheet1"）.Range（"A1:

B2"）.Offset（2,2）.Select

EndSub

 

使用Resize属性返回调整后的单元格区域

SubRngResize（）

Sheets（"Sheet1"）.Range（"A1"）.Resize（4,4）.Select

EndSub

范例2选定单元格区域的方法

使用Select方法

SubRngSelect（）

Sheets（"Sheet2"）.Activate

Sheets（"Sheet2"）.Range（"A1:

B10"）.Select

EndSub

使用Activate方法

SubRngActivate（）

Sheets（"Sheet2"）.Activate

Sheets（"Sheet2"）.Range（"A1:

B10"）.Activate

EndSub

使用Goto方法

SubRngGoto（）

Application.GotoReference:

=Sheets（"Sheet2"）.Range（"A1：

B10"）,Scroll:

=True

EndSub

范例3获得指定行的最后一个非空单元格

SubLastCell（）

DimrngAsRange

Setrng=Cells（Rows.Count,1）.End（xlUp）

MsgBox"A列的最后一个非空单元格是"&rng.Address（0,0）_

&",行号"&rng.Row&",数值"&rng.Value

Setrng=Nothing

EndSub

范例4使用SpecialCells方法定位单元格

SubSpecialAddress（）

DimrngAsRange

Setrng=Sheet1.UsedRange.SpecialCells（xlCellTypeFormulas）

rng.Select

MsgBox"工作表中有公式的单元格为：

"&rng.Address

Setrng=Nothing

EndSub

范例5查找特定内容的单元格

使用Find方法查找特定信息

SubFindCell（）

DimStrFindAsString

DimrngAsRange

StrFind=InputBox（"请输入要查找的值：

"）

IfLen（Trim（StrFind））>0Then

WithSheet1.Range（"A:

A"）

Setrng=.Find（What:

=StrFind,_

After:

=.Cells（.Cells.Count）,_

LookIn:

=xlValues,_

LookAt:

=xlWhole,_

SearchOrder:

=xlByRows,_

SearchDirection:

=xlNext,_

MatchCase:

=False）

IfNotrngIsNothingThen

Application.Gotorng,True

Else

MsgBox"没有找到匹配单元格!

"

EndIf

EndWith

EndIf

Setrng=Nothing

EndSub

SubFindNextCell（）

DimStrFindAsString

DimrngAsRange

DimFindAddressAsString

StrFind=InputBox（"请输入要查找的值：

"）

IfLen（Trim（StrFind））>0Then

WithSheet1.Range（"A:

A"）

.Interior.ColorIndex=0

Setrng=.Find（What:

=StrFind,_

After:

=.Cells（.Cells.Count）,_

LookIn:

=xlValues,_

LookAt:

=xlWhole,_

SearchOrder:

=xlByRows,_

SearchDirection:

=xlNext,_

MatchCase:

=False）

IfNotrngIsNothingThen

FindAddress=rng.Address

Do

rng.Interior.ColorIndex=6

Setrng=.FindNext（rng）

LoopWhileNotrngIsNothing_

Andrng.Address<>FindAddress

EndIf

EndWith

EndIf

Setrng=Nothing

EndSub

使用Like运算符进行模式匹配查找

SubRngLike（）

DimrngAsRange

DimrAsInteger

r=1

Sheet1.Range（"A:

A"）.ClearContents

ForEachrngInSheet2.Range（"A1:

A40"）

Ifrng.TextLike"*a*"Then

Cells（r,1）=rng.Text

r=r+1

EndIf

Next

Setrng=Nothing

EndSub

范例6替换单元格内字符串

SubReplacement（）

Range（"A:

A"）.Replace_

What:

="市",Replacement:

="区",_

LookAt:

=xlPart,SearchOrder:

=xlByRows,_

MatchCase:

=True

EndSub

范例7单元格的复制

复制单元格区域

SubRangeCopy（）

Sheet1.Range（"A1:

G7"）.CopySheet2.Range（"A1"）

EndSub

SubCopyalltheforms（）

DimiAsInteger

Sheet1.Range（"A1:

G7"）.Copy

WithSheet3.Range（"A1"）

.PasteSpecialxlPasteAll

.PasteSpecialxlPasteColumnWidths

EndWith

Application.CutCopyMode=False

Fori=1To7

Sheet3.Rows（i）.RowHeight=Sheet1.Rows（i）.RowHeight

Next

EndSub

仅复制数值到另一区域

SubCopyValue（）

Sheet1.Range（"A1:

G7"）.Copy

Sheet2.Range（"A1"）.PasteSpecialPaste:

=xlPasteValues

Application.CutCopyMode=False

EndSub

SubGetValueResize（）

WithSheet1.Range（"A1"）.CurrentRegion

Sheet3.Range（"A1"）.Resize（.Rows.Count,.Columns.Count）.Value=.Value

EndWith

EndSub

范例8禁用单元格拖放功能

PrivateSubWorksheet_SelectionChange（ByValTargetAsRange）

IfTarget.Column=1Then

Application.CellDragAndDrop=False

Else

Application.CellDragAndDrop=True

EndIf

EndSub

PrivateSubWorksheet_Deactivate（）

Application.CellDragAndDrop=True

EndSub

范例9设置单元格格式

设置单元格字体格式

SubCellFont（）

WithRange（"A1"）.Font

.Name="华文彩云"

.FontStyle="Bold"

.Size=22

.ColorIndex=3

.Underline=2

EndWith

EndSub

设置单元格内部格式

SubCellInternalFormat（）

WithRange（"A1"）.Interior

.ColorIndex=3

.Pattern=xlPatternGrid

.PatternColorIndex=6

EndWith

EndSub

单元格区域添加边框

SubCellBorder（）

DimrngAsRange

Setrng=Range（"B2:

E8"）

Withrng.Borders（xlInsideHorizontal）

.LineStyle=xlDot

.Weight=xlThin

.ColorIndex=xlColorIndexAutomatic

EndWith

Withrng.Borders（xlInsideVertical）

.LineStyle=xlContinuous

.Weight=xlThin

.ColorIndex=xlColorIndexAutomatic

EndWith

rng.BorderAroundxlContinuous,xlMedium,xlColorIndexAutomatic

Setrng=Nothing

EndSub

SubQuickBorder（）

Range（"B12:

E18"）.Borders.LineStyle=xlContinuous

EndSub

范例10单元格的数据有效性

添加数据有效性

SubAddValidation（）

WithRange（"A1:

A10"）.Validation

.Delete

.AddType:

=xlValidateList,_

AlertStyle:

=xlValidAlertStop,_

Operator:

=xlBetween,_

Formula1:

="1,2,3,4,5,6,7,8"

.ErrorMessage="只能输入1-8的数值,请重新输入!

"

EndWith

EndSub

判断是否存在数据有效性

SubErrValidation（）

OnErrorGoToLine

IfRange（"A1"）.Validation.Type>=0Then

MsgBox"有数据有效性!

"

ExitSub

EndIf

Line:

MsgBox"没有数据有效性!

"

EndSub

动态的数据有效性

PrivateSubWorksheet_SelectionChange（ByValTargetAsRange）

IfTarget.Column=1AndTarget.Count=1AndTarget.Row>1Then

WithTarget.Validation

.Delete

.AddType:

=xlValidateList,_

AlertStyle:

=xlValidAlertStop,_

Operator:

=xlBetween,_

Formula1:

="主机,显示器"

EndWith

EndIf

EndSub

PrivateSubWorksheet_Change（ByValTargetAsRange）

IfTarget.Column=1AndTarget.Row>1AndTarget.Count=1Then

WithTarget.Offset（0,1）.Validation

.Delete

SelectCaseTarget

Case"主机"

.AddType:

=xlValidateList,_

AlertStyle:

=xlValidAlertStop,_

Operator:

=xlBetween,_

Formula1:

="Z286,Z386,Z486,Z586"

Case"显示器"

.AddType:

=xlValidateList,_

AlertStyle:

=xlValidAlertStop,_

Operator:

=xlBetween,_

Formula1:

="15,17,21,25"

EndSelect

EndWith

EndIf

EndSub

范例11单元格中的公式

在单元格中写入公式

SubrngFormula（）

DimrAsInteger

r=Cells（Rows.Count,1）.End（xlUp）.Row

Range（"C2"）.Formula="=A2*B2"

Range（"C2"）.CopyRange（"C3:

C"&r）

Range（"A"&r+1）="合计"

Range（"C"&r+1）.Formula="=SUM（C2:

C"&r&"）"

EndSub

SubrngFormulaRC（）

DimrAsInteger

r=Cells（Rows.Count,1）.End（xlUp）.Row

Range（"C2:

C"&r）.FormulaR1C1="=RC[-2]*RC[-1]"

Range（"A"&r+1）="合计"

Range（"C"&r+1）.FormulaR1C1="=SUM（R[-"&r-1&"]C:

R[-1]C）"

EndSub

SubRngFormulaArray（）

DimrAsInteger

r=Cells（Rows.Count,1）.End（xlUp）.Row

Range（"C2:

C"&r）.FormulaR1C1="=RC[-2]*RC[-1]"

Range（"A"&r+1）="合计"

Range（"C"&r+1）.FormulaArray="=SUM（R[-"&r-1&"]C[-2]:

R[-1]C[-2]*R[-"&r-1&"]C[-1]:

R[-1]C[-1]）"

EndSub

判断单元格是否包含公式

SubrngIsHasFormula（）

SelectCaseSelection.HasFormula

CaseTrue

MsgBox"单元格包含公式!

"

CaseFalse

MsgBox"单元格没有公式!

"

CaseElse

MsgBox"公式区域：

"&Selection.SpecialCells（-4123,23）.Address（0,0）

EndSelect

EndSub

判断单元格公式是否存在错误

SubCellFormulaIsWrong（）

IfIsError（Range（"A1"）.Value）=TrueThen

MsgBox"A1单元格错误类型为:

"&Range（"A1"）.Text

Else

MsgBox"A1单元格公式结果为"&Range（"A1"）.Value

EndIf

EndSub

取得公式的引用单元格

SubRngPrecedent（）

DimrngAsRange

Setrng=Sheet1.Range（"C10"）.Precedents

MsgBox"公式所引用的单元格是：

"&rng.Address

Setrng=Nothing

EndSub

将公式转换为数值

SubSpecialPaste（）

WithRange（"A1:

A10"）

.Copy

.PasteSpecialPaste:

=xlPasteValues

EndWith

Application.CutCopyMode=False

EndSub

范例12单元格添加批注

SubAddComment（）

WithRange（"A1"）

IfNot.CommentIsNothingThen.Comment.Delete

.AddCommentText:

=Date&vbCrLf&.Text

.Comment.Visible=True

EndWith

EndSub

范例13合并单元格操作

判断单元格区域是否存在合并单元格

SubIsMergeCell（）

IfRange（"A1"）.MergeCellsThen

MsgBox"合并单元格",vbInformation

Else

MsgBox"非合并单元格",vbInformation

EndIf

EndSub

SubIsMergeCells（）

IfIsNull（Range（"A1:

D10"）.MergeCells）Then

MsgBox"包含合并单元格",vbInformation

Else

MsgBox"没有包含合并单元格",vbInformation

EndIf

EndSub

合并单元格时连接每个单元格的文本

SubMergeCells（）

DimMergeStrAsString

DimMergeRngAsRange

DimrngAsRange

SetMergeRng=Range（"A1:

B2"）

ForEachrngInMergeRng

MergeStr=MergeStr&rng&""

Next

Application.DisplayAlerts=False

MergeRng.Merge

MergeRng.Value=MergeStr

Application.DisplayAlerts=True

SetMergeRng=Nothing

Setrng=Nothing

EndSub

合并内容相同的连续单元格

SubMergeLinkedCell（）

DimrAsInteger

DimiAsInteger

Application.DisplayAlerts=False

WithSheet1

r=.Cells（Rows.Count,1）.End（xlUp）.Row

Fori=rTo2Step-1

If.Cells（i,2）.Value=.Cells（i-1,2）.ValueThen

.Range（.Cells（i-1,2）,.Cells（i,2））.Merge

EndIf

Next

EndWith

Application.DisplayAlerts=True

EndSub

取消合并单元格时在每个单元格中保留内容

SubCancelMergeCells（）

DimrAsInteger

DimMergeStrAsString

DimMergeCotAsInteger

DimiAsInteger

WithSheet1

r=.Cells（.Rows.Count,1）.End（xlUp）.Row

Fori=2Tor

MergeStr=.Cells（i,2）.Value

MergeCot=.Cells（i,2）.MergeArea.Count

.Cells（i,2）.UnMerge

.Range（.Cells（i,2）,.Cells（i+MergeCot-1,2））.Value=MergeStr

i=i+MergeCot-1

Next

.Range（"B1:

B"&r）.Borders.LineStyle=xlContinuous

EndWith

EndSub

范例14高亮显示选定单元格区域

PrivateSubWorksheet_SelectionChange（ByValTargetAsRange）

Cells.Interior.ColorIndex=xlColorIndexNone

Target.Interior.ColorIndex=Int（56*Rnd（）+1）

EndSub

PrivateSubWorksheet_SelectionChange（ByValTargetAsRange）

DimrngAsRange

Cells.Interior.ColorIndex=xlColorIndexNone

Setrng=Application.Union（Target.EntireColumn,Target.EntireRow）

rng.Interior.ColorIndex=Int（56*Rnd（）+1）

Setrng=Nothing

EndSub

范例15双击被保护单元格时不显示提示消息框

PrivateSubWorksheet_BeforeDoubleClick（ByValTargetAsRange,CancelAsBoolean）

IfTarget.Locked=TrueThen

MsgBox"此单元格已保护，不能编辑!

"

Cancel=True

EndIf

EndSub

范例16单元格录入数据后自动保护

PrivateSubWorksheet_SelectionChange（ByValTargetAsRange）

DimmsgAsByte

WithTarget

IfNotApplication.Intersect（Target,Range（"A2:

F6"））Is

展开阅读全文
相关资源
猜你喜欢
相关搜索

当前位置：首页 > 高等教育 > 文学

copyright@ 2008-2022 冰豆网网站版权所有

经营许可证编号:鄂ICP备2022015515号-1