Excel VBA类代码实例集锦.docx
《Excel VBA类代码实例集锦.docx》由会员分享,可在线阅读,更多相关《Excel VBA类代码实例集锦.docx(58页珍藏版)》请在冰豆网上搜索。
![Excel VBA类代码实例集锦.docx](https://file1.bdocx.com/fileroot1/2023-6/6/4e34981f-24a1-4d2e-80a0-f3fb30548a51/4e34981f-24a1-4d2e-80a0-f3fb30548a511.gif)
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