ExcelVBA类代码实例集锦.docx

资源描述

ExcelVBA类代码实例集锦.docx

《ExcelVBA类代码实例集锦.docx》由会员分享，可在线阅读，更多相关《ExcelVBA类代码实例集锦.docx（56页珍藏版）》请在冰豆网上搜索。

ExcelVBA类代码实例集锦.docx

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

="控件事件：

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

="控件事件：

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

="控件事件：

KeyUp"&vbCrLf&_

"控件名称：

"&frm.Controls（"Textbox"&Index）.Name&vbCrLf&_

"按键值：

&H"&Hex$（KeyCode）

EndIf

EndSub

PrivateSubmyText_MouseMove（ByValButtonAsInteger,ByValShiftAsInteger,ByValXAsSingle,ByValYAsSingle）

SelectCaseIndex

Case3

="3"

Case8

="8"

Case4

="4"

Case9

="9"

CaseElse

=""

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

Else

EndIf

Else

n=n-1

a=Replace（a,Format（index,"00"）,""）

Fori=1To18

frm.Controls（"checkbox"&i）.Enabled=True

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'类窗体也和当前窗体建立关联

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

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控件

=""

'清空文本框

K=K+1:

SetAr（K）=NewTT

'同时创建类实体

Ar（K）.tkj

'给类实体赋值，激活事件。

EndIf

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

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

.CommandButton1.Enabled=True

.CommandButton2.Enabled=False

EndWith

EndSub

PrivateSubmBox_MouseDown（ByValButtonAsInteger,ByValShiftAsInteger,ByValXAsSingle,ByValYAsSingle）

Fori=2To4

WithUserForm1.Controls（"TextBox"&i）

.ForeColor=0

.BackColor=

EndWith

mBox.BackColor=

mBox.ForeColor=

EndSub

窗体代码：

Privated（1To4）AsNewcmd_Class

PrivateSubCommandButton1_Click（）

Fori=1To3

Setd（i）.mBox=,True）

Withd（i）.mBox

.Left=10

.Top=（i-1）*30+3

.Width=70

.Height=20

.Text=.Name

EndWith

Nexti

Setd（4）.cmd=,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=

EndWith

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

Fori=1To4

SettxtNew=NewTxtArray

SettxtNew.txt=Me.Controls（"TextBox"&i）

SetarrTxt（i）=txtNew

SettxtNew=Nothing

EndSub

8，横道图

快盘\Mytb\更新\类\类入门\.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

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））

CaseIs

Fori=1Totg.Offset（1,0）.Column-1