Excel VBA类代码实例集锦.docx
《Excel VBA类代码实例集锦.docx》由会员分享，可在线阅读，更多相关《Excel VBA类代码实例集锦.docx（49页珍藏版）》请在冰豆网上搜索。
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&_sxYEE。
"Text属性：
"&frm.Controls（"Textbox"&Index）.Text
EndIf
EndSub
PrivateSubmyText_DblClick（ByValCancelAsMSForms.ReturnBoolean）urBVw。
Index=Mid（myText.Name,8）
Iffrm.Controls（"Textbox"&Index）<>""Then
frm.Label1.Caption="控件事件：
DblClick"&vbCrLf&_
"控件名称：
"&frm.Controls（"Textbox"&Index）.Name&vbCrLf&_O4zQU。
"Cancel属性：
"&Cancel
EndIf
EndSub
KeyUp事件与Change事件重迭，二者取其一
PrivateSubmyText_KeyUp（ByValKeyCodeAsMSForms.ReturnInteger,ByValShiftAsInteger）SoKBT。
Index=Mid（myText.Name,8）
Iffrm.Controls（"Textbox"&Index）<>""Then
frm.Label1.Caption="控件事件：
KeyUp"&vbCrLf&_
"控件名称：
"&frm.Controls（"Textbox"&Index）.Name&vbCrLf&_0moOR。
"按键值：
&H"&Hex$（KeyCode）
EndIf
EndSub
PrivateSubmyText_MouseMove（ByValButtonAsInteger,ByValShiftAsInteger,ByValXAsSingle,ByValYAsSingle）lDGy4。
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&vbCrLfYw6SY。
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）控件创建关键hPKtm。
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）'第一个不需要类模块R8nJN。
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）5jklB。
'限制只可以输入数字，不可输入字母和其他符号
SelectCaseKeyAscii
Case48To57
Case46
IfInStr（1,t.Text,"."）Then
KeyAscii=0
EndIf
CaseElse
KeyAscii=0
EndSelect
EndSub
PrivateSubt_KeyUp（ByValKeyCodeAsMSForms.ReturnInteger,ByValShiftAsInteger）99kP5。
'限制中文输入
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）.ObjectIUNE1。
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.Name732ox。
ElseIfTypeName（ctl）="CommandButton"Then
Ifctl.Name<>"CommandButton1"Andctl.Name<>"CommandButton2"Then.Controls.Removectl.Name0Go7h。
EndIf
Next
.CommandButton1.Enabled=True
.CommandButton2.Enabled=False
EndWith
EndSub
PrivateSubmBox_MouseDown（ByValButtonAsInteger,ByValShiftAsInteger,ByValXAsSingle,ByValYAsSingle）EKHKf。
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）SaSUo。
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）vjrAh。
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.CaptionW2cGF。
EndSub
类模块TxtArray代码：
PublicWithEventstxtAsMSForms.TextBox
PrivateSubtxt_MouseDown（ByValButtonAsInteger,ByValShiftAsInteger,ByValXAsSingle,ByValYAsSingle）zj7WA。
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）efgJZ。
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））o2rZg。
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）AsSingleoKTiJ。
DimtgAsRange,StartPointLeftAsSingle,iAsIntegerZhpH9。
ForEachtgInarr
IfIsDate（tg.value）Then
IfYear（StartDate）=Year（tg.value）AndMonth（StartDate）=Month（tg.value）ThenZLRc4。
'IfDateValue（Year（StartDate）&"-"&Month（StartDate）&"-"&"1"）=DateValue（tg.Value）TheniSUU0。
Debug.PrintDay（StartDate）
SelectCaseCInt（Day（StartDate））
CaseIsFori=
升级会员 