Excel VBA类代码实例集锦.docx
《Excel VBA类代码实例集锦.docx》由会员分享，可在线阅读，更多相关《Excel VBA类代码实例集锦.docx（58页珍藏版）》请在冰点文库上搜索。
ExcelVBA类代码实例集锦
1,类动态数组控件
‘2007VBA技巧
‘快盘\Mytb\更新\类\类动态数组控件、xlsm
‘2013-6-16
类模块代码:
PublicWithEventsfrmAsMSForms、UserForm
PublicWithEventsmyTextAsMSForms、TextBox
PublicIndexAsInteger
PrivateSubmyText_Change（）
Index=Mid（myText、Name,8）
Iffrm、Controls（"Textbox"&Index）<>""Then
frm、Label1、Caption="控件事件:
Change"&vbCrLf&_
"控件名称:
"&frm、Controls（"Textbox"&Index）、Name&vbCrLf&_
"Text属性:
"&frm、Controls（"Textbox"&Index）、Text
EndIf
EndSub
PrivateSubmyText_DblClick（ByValCancelAsMSForms、ReturnBoolean）
Index=Mid（myText、Name,8）
Iffrm、Controls（"Textbox"&Index）<>""Then
frm、Label1、Caption="控件事件:
DblClick"&vbCrLf&_
"控件名称:
"&frm、Controls（"Textbox"&Index）、Name&vbCrLf&_
"Cancel属性:
"&Cancel
EndIf
EndSub
KeyUp事件与Change事件重迭,二者取其一
PrivateSubmyText_KeyUp（ByValKeyCodeAsMSForms、ReturnInteger,ByValShiftAsInteger）
Index=Mid（myText、Name,8）
Iffrm、Controls（"Textbox"&Index）<>""Then
frm、Label1、Caption="控件事件:
KeyUp"&vbCrLf&_
"控件名称:
"&frm、Controls（"Textbox"&Index）、Name&vbCrLf&_
"按键值:
&H"&Hex$（KeyCode）
EndIf
EndSub
PrivateSubmyText_MouseMove（ByValButtonAsInteger,ByValShiftAsInteger,ByValXAsSingle,ByValYAsSingle）
SelectCaseIndex
Case3
Userform2、Label2、Caption="3"
Case8
Userform2、Label2、Caption="8"
Case4
Userform2、Label2、Caption="4"
Case9
Userform2、Label2、Caption="9"
CaseElse
Userform2、Label2、Caption=""
EndSelect
EndSub
模块1代码:
Publica（1To14）AsmyText
Subformshow（）
Userform2、Show
EndSub
窗体代码:
PrivateSubCommandButton1_Click（）
Dimi&,t$
Fori=1To14
Ifa（i）、myText、Text<>""Then
t=t&"控件名称:
"&a（i）、myText、Name&vbTab&"Text属性:
"&a（i）、myText、Text&vbCrLf
EndIf
Nexti
MsgBoxt
EndSub
PrivateSubUserForm_Initialize（）
Dimi&
Fori=1To14
Seta（i）=NewmyText
Seta（i）、myText=Me、Controls（"Textbox"&i）
Seta（i）、frm=Me
Nexti
EndSub
工作表代码:
PrivateSubCommandButton1_Click（）
Userform2、Show
EndSub
2,复选框选择
‘快盘\Mytb\更新\类\类0928、、xls
‘当复选框选择到7个时,其它的复选框不能再选择。
当复选框选择小于7个,其它的复选框还能继续选择。
类模块代码:
PublicWithEventscheAsMSForms、CheckBox
PublicWithEventsfrmAsMSForms、UserForm
PrivateSubche_Change（）'类的数据改变事件
DimindexAsLong
index=Mid（che、Name,9）'取出checkboxN中的数字N
Iffrm、Controls（"checkbox"&index）=TrueThen
a=a&Format（index,"00"）&","
n=n+1
Ifn=7Then
Fori=1To18
b=Format（i,"00"）
IfInStr（a,b）=0Then
frm、Controls（"checkbox"&i）、Enabled=False
EndIf
Next
Else
EndIf
Else
n=n-1
a=Replace（a,Format（index,"00"）,""）
Fori=1To18
frm、Controls（"checkbox"&i）、Enabled=True
Next
EndIf
EndSub
模块1代码:
Publicnewclass（1To18）Asche类,n&,a$
Subformshow（）
UserForm1、Show
EndSub
窗体代码:
PrivateSubUserForm_Initialize（）
Fori=1To18
Setnewclass（i）=Newche类'创建一个新的che类对象
Setnewclass（i）、che=Controls（"checkbox"&i）'设置新类与checkbox（i）控件创建关键
Setnewclass（i）、frm=Me'类窗体也与当前窗体建立关联
Next
EndSub
3,限制多个TEXTBOX的输入,使其只能输入数值
‘快盘\Mytb\更新\类\如何限制多个TEXTBOX的输入_zhaogang1980、xls
‘6447-1-1、html
类模块代码:
PublicWithEventsTxtboxAsMSForms、TextBox
PrivateSubTxtbox_Change（）
WithCreateObject（"vbscript、regexp"）
、Global=True
、Pattern="[^0-9、]+"
If、test（Txtbox、Text）Then
Txtbox、Text=、Replace（Txtbox、Text,""）
EndIf
EndWith
EndSub
模块1代码:
SubMacro1（）
UserForm1、Show
EndSub
窗体代码:
DimTxt（）AsNewclsTxt
PrivateSubUserForm_Initialize（）
DimctlAsControl,m&
ForEachctlInMe、Controls
IfTypeName（ctl）="TextBox"Then
Ifctl、Name<>"TextBox1"Then
m=m+1
ReDimPreserveTxt（1Tom）
SetTxt（m）、Txtbox=ctl
EndIf
EndIf
Next
EndSub
PrivateSubTextBox1_Exit（ByValCancelAsMSForms、ReturnBoolean）'第一个不需要类模块
IfTextBox1、Text=""ThenExitSub
IfIsDate（TextBox1、Text）=FalseThen
Cancel=True
TextBox1、Text=""
EndIf
EndSub
4,限制输入字母
‘8095-1-1-14725、html
PrivateWithEventstAsMSForms、TextBox
PrivateSubt_KeyPress（ByValKeyAsciiAsMSForms、ReturnInteger）
'限制只可以输入数字,不可输入字母与其她符号
SelectCaseKeyAscii
Case48To57
Case46
IfInStr（1,t、Text,"、"）Then
KeyAscii=0
EndIf
CaseElse
KeyAscii=0
EndSelect
EndSub
PrivateSubt_KeyUp（ByValKeyCodeAsMSForms、ReturnInteger,ByValShiftAsInteger）
'限制中文输入
WithCreateObject（"vbscript、regexp"）
、Global=True
、Pattern="[^0-9、]+"
If、test（t、Text）Then
t、Text=、Replace（t、Text,""）
EndIf
EndWith
EndSub
PublicSubtk（iAsOLEObject）
'获取oleboject对象
Sett=i、Object
EndSub
DimAr（1To100）AsTT
'定义数组类
Subjustest（）
DimjAsOLEObject,KAsByte
ForEachjInSheet1、OLEObjects
IfTypeName（j、Object）="TextBox"Then
'如果为TEXTBOX控件
j、Object、Text=""
'清空文本框
K=K+1:
SetAr（K）=NewTT
'同时创建类实体
Ar（K）、tkj
'给类实体赋值,激活事件。
EndIf
Next
EndSub
5,表格上的按钮
‘telnet_zhaogang1960。
xls
‘类模块clsCmd中代码:
PublicWithEventsCmdboxAsMSForms、CommandButton
PrivateSubCmdbox_Click（）
MsgBoxCmdbox、Caption
EndSub
‘表格1上的ActiveX按钮控件
DimCmd（1To3）AsNewclsCmd
PrivateSubWorksheet_Activate（）
DimiAsByte
Fori=1To3
SetCmd（i）、Cmdbox=Me、OLEObjects（"CommandButton"&i）、Object
Next
EndSub
PrivateSubWorksheet_Deactivate（）
EraseCmd
EndSub
6,求助由代码生成的控件的事件by:
山菊花
‘当光标移入某个文本框,这个文本框的背景色变为蓝色,前景改为白色
‘7834-1-1、html
类模块代码:
PublicWithEventscmdAsMSForms、CommandButton
PublicWithEventsmBoxAsMSForms、TextBox
PrivateSubcmd_Click（）
DimctlAsMSForms、Control
WithUserForm1
ForEachctlIn、Controls
IfTypeName（ctl）="TextBox"Then
Ifctl、Name<>"TextBox1"Then、Controls、Removectl、Name
ElseIfTypeName（ctl）="CommandButton"Then
Ifctl、Name<>"CommandButton1"Andctl、Name<>"CommandButton2"Then、Controls、Removectl、Name
EndIf
Next
、CommandButton1、Enabled=True
、CommandButton2、Enabled=False
EndWith
EndSub
PrivateSubmBox_MouseDown（ByValButtonAsInteger,ByValShiftAsInteger,ByValXAsSingle,ByValYAsSingle）
Fori=2To4
WithUserForm1、Controls（"TextBox"&i）
、ForeColor=0
、BackColor=16777215
EndWith
Next
mBox、BackColor=16711680
mBox、ForeColor=16777215
EndSub
窗体代码:
Privated（1To4）AsNewcmd_Class
PrivateSubCommandButton1_Click（）
Fori=1To3
Setd（i）、mBox=Frame1、Controls、Add（"forms、TextBox、1",,True）
Withd（i）、mBox
、Left=10
、Top=（i-1）*30+3
、Width=70
、Height=20
、Text=、Name
EndWith
Nexti
Setd（4）、cmd=Me、Controls、Add（"forms、CommandButton、1",,True）
Withd（4）、cmd
、Left=CommandButton2、Left
、Top=CommandButton2、Top+CommandButton2、Height
、Width=CommandButton2、Width
、Height=CommandButton2、Height
、Caption="删除"
EndWith
CommandButton1、Enabled=False
CommandButton2、Enabled=True
EndSub
PrivateSubCommandButton2_Click（）
Fori=2To4
WithControls（"TextBox"&i）
TextBox1、Value=Val（TextBox1、Value）+Val（、Value）
、ForeColor=0
、BackColor=16777215
EndWith
Next
EndSub
7,窗体键盘
‘快盘\Mytb\更新\类\可否实现窗体键盘、xls
模块1代码:
PublicsNameAsString
类模块CmdArray代码:
PublicWithEventscmdAsMSForms、CommandButton
PrivateSubcmd_Click（）
UserForm1、Controls（sName）、Text=UserForm1、Controls（sName）、Text&cmd、Caption
EndSub
类模块TxtArray代码:
PublicWithEventstxtAsMSForms、TextBox
PrivateSubtxt_MouseDown（ByValButtonAsInteger,ByValShiftAsInteger,ByValXAsSingle,ByValYAsSingle）
sName=txt、Name
EndSub
窗体代码:
PrivatearrCmd（0To10）AsCmdArray
PrivatearrTxt（1To4）AsTxtArray
PrivateSubUserForm_Initialize（）
DimiAsInteger
DimcmdNewAsCmdArray
DimtxtNewAsTxtArray
Fori=0To10
SetcmdNew=NewCmdArray
SetcmdNew、cmd=Me、Controls（"CommandButton"&i）
SetarrCmd（i）=cmdNew
SetcmdNew=Nothing
Next
Fori=1To4
SettxtNew=NewTxtArray
SettxtNew、txt=Me、Controls（"TextBox"&i）
SetarrTxt（i）=txtNew
SettxtNew=Nothing
Next
EndSub
8,横道图
快盘\Mytb\更新\类\类入门\横道图_a371014988、xls
模块1代码:
Sub画线条（）
DimstAsWorksheet,arrAsRange,tgAsRange
Setst=Sheets（"横道图"）
Setarr=st、Range（"A5:
A"&st、Range（"A65536"）、End（xlUp）、Row）
ForEachtgInarr
DimLiAsNew类1
Li、SDate=DateValue（tg、Offset（0,3））
Li、Edate=DateValue（tg、Offset（0,4））
Li、st=st
Li、target=tg
Li、arr=st、Range（Cells（2,7）,st、Cells（2,255）、End（xlToLeft））
IfLi、lineThenDebug、Printtg
Next
EndSub
类模块类1代码:
'取左
Privatem_stAsWorksheet
PrivateM_SDateAsDate
PrivateM_EDateAsDate
PrivateM_targetAsRange
PrivateM_arrAsRange
ConstHeightAsInteger=3
PublicPropertyGetEdate（）AsDate
Edate=M_EDate
EndProperty
PublicPropertyLetEdate（valueAsDate）
M_EDate=value
EndProperty
PublicPropertyGetSDate（）AsDate
SDate=M_SDate
EndProperty
PublicPropertyLetSDate（valueAsDate）
M_SDate=value
EndProperty
PublicPropertyGetst（）AsWorksheet
Setst=m_st
EndProperty
PublicPropertyLetst（stvalueAsWorksheet）
Setm_st=stvalue
EndProperty
PublicPropertyGettarget（）AsRange
Settarget=M_target
EndProperty
PublicPropertyLettarget（tgvalueAsRange）
SetM_target=tgvalue
EndProperty
PublicPropertyGetarr（）AsRange
Setarr=M_arr
EndProperty
PublicPropertyLetarr（valueAsRange）
SetM_arr=value
EndProperty
PublicFunctionGetDateLineLeft（ByValStartDateAsDate）AsSingle
DimtgAsRange,StartPointLeftAsSingle,iAsInteger
ForEachtgInarr
IfIsDate（tg、value）Then
IfYear（StartDate）=Year（tg、value）AndMonth（StartDate）=Month（tg、value）Then
'IfDateValue（Year（StartDate）&"-"&Month（StartDate）&"-"&"1"）=DateValue（tg、Value）Then
Debug、PrintDay（StartDate）
SelectCaseCInt（Day（StartDate））
CaseIsFori=1Totg、Offset（1,0）、Column-1
StartPointLeft=StartPointLeft+st、Columns（i）、Width
Nexti
GetDateLineLeft=StartPointLeft+（CInt（Day（StartDate））Mod10）*st、Colum
升级会员 