ExcelVBA类代码实例集锦.docx

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

1、1, 类动态数组控件 2007VBA 技巧快盘Mytb更新类类动态数组控件.xlsm2013-6-16类模块代码：Public WithEvents frm As MSForms.UserFormPublic WithEvents myText As MSForms.TextBoxPublic Index As IntegerPrivate Sub myText_Change()Index = Mid(myText.Name, 8)If frm.Controls(Textbox & Index) Thenfrm.Labell.Caption = 控件事件：Change & vbCrLf & _

2、控件名称：& frm.Controls(Textbox & Index).Name & vbCrLf &Text 属性：& frm.Controls(Textbox & Index).TextEnd SubPrivate Sub myText_DblClick(ByVal Cancel As MSForms.ReturnBoolean)Index = Mid(myText.Name, 8)If frm.Controls(Textbox & Index) Thenfrm.Labell.Caption = 控件事件：DblClick & vbCrLf & _控件名称：& frm.Controls(

3、Textbox & Index).Name & vbCrLf & _Cancel 属性：& CancelEnd IfEnd SubKeyUp事件与Change事件重迭，二者取其一Private Sub myText_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)Index = Mid(myText.Name, 8)If frm.Controls(Textbox & Index) Then控件名称：& frm.Controls(Textbox & Index).Name & vbCrLf & _按键值：&

4、H & Hex$(KeyCode)End IfEnd SubPrivate Sub myText_MouseMove(ByValButton As Integer, ByValShift As Integer, ByVal X As Single, ByVal Y As Single)Select Case IndexCase 3Userform2.Label2.Caption = 3Case 8Userform2.Label2.Caption = 8Case 4Userform2.Label2.Caption = 4Case 9Userform2.Label2.Caption = 9Case

5、 ElseUserform2.Label2.Caption =End SelectEnd Sub模块1代码：Public a(1 To 14) As myTextSub formshow()Userform2.ShowEnd Sub窗体代码：Private Sub CommandButton1_Click()Dim i&, t$For i = 1 To 14If a(i).myText.Text Thent = t & 控件名称：& a(i).myText.Name & vbTab & Text 属性：&a(i).myText.Text & vbCrLfEnd IfNext iMsgBox t

6、End SubPrivate Sub UserForm_Initialize()Dim i&For i = 1 To 14Set a(i) = New myTextSet a(i).myText = Me.Controls(Textbox & i)Set a(i).frm = MeNext iEnd Sub工作表代码：Private Sub CommandButton1_Click()Userform2.Show2, 复选框选择快盘Mytb更新类类0928.xls当复选框选择到7个时，其它的复选框不能再选择。当复选框选择小于7个，其它的复 选框还能继续选择。类模块代码：Public WithE

7、vents che As MSForms.CheckBoxPublic WithEvents frm As MSForms.UserFormPrivate Sub che_Change()类的数据改变事件Dim index As Longindex = Mid(che.Name, 9)取出 checkboxN 中的数字 NIf frm.Controls(checkbox & index) = True Thena = a & Format(index, 00) & ,n = n + 1If n = 7 ThenFor i = 1 To 18b = Format(i, 00)If InStr(a

8、, b) = 0 Thenfrm.Controls(checkbox & i).Enabled = FalseEnd IfNextElseEnd IfElsen = n - 1a = Replace(a, Format(index, 00),)For i = 1 To 18frm.Controls(checkbox & i).Enabled = TrueNextEnd IfEnd Sub模块1代码：Public newclass(1 To 18) As che 类，n&, a$Sub formshow()UserForml.ShowEnd Sub窗体代码：Private Sub UserFor

9、m_Initialize()For i = 1 To 18Set newclass(i) = New che类创建一个新的che类对象Set newclass(i).che = Controls(checkbox & i)设置新类和 checkbox(i) 控件创建关键Set newclass(i).frm = Me类窗体也和当前窗体建立关联NextEnd Sub3, 限制多个TEXTBOX的输入，使其只能输入数值快盘Mytb更新类如何限制多个TEXTBOX的输入_zhaogang1980.xls类模块代码:Public WithEvents Txtbox As MSForms.TextBox

10、Private Sub Txtbox_Change()With CreateObject(vbscript.regexp).Global = True.Pattern = 0-9.+If .test(Txtbox.Text) ThenTxtbox.Text = .Replace(Txtbox.Text,)End IfEnd WithEnd Sub模块1代码：Sub Macro1()UserForml.ShowEnd Sub窗体代码：Dim Txt() As New clsTxtPrivate Sub UserForm_Initialize()Dim ctl As Control, m&For

11、Each ctl In Me.ControlsIf TypeName(ctl) = TextBox ThenIf ctl.Name TextBox1 Then m = m + 1ReDim Preserve Txt(1 To m)Set Txt(m).Txtbox = ctlEnd IfEnd IfNextEnd SubPrivate Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)第一个不 需要类模块If TextBox1.Text = Then Exit SubIf IsDate(TextBox1.Text) = False

12、ThenCancel = TrueTextBoxl.Text =End IfEnd Sub4, 限制输入字母Private WithEvents t As MSForms.TextBoxPrivate Sub t_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)限制只可以输入数字，不可输入字母和其他符号Select Case KeyAsciiCase 48 To 57Case 46If InStr(1, t.Text, .) ThenKeyAscii = 0End IfCase ElseKeyAscii = 0End SelectEnd Sub

13、Private Sub t_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)限制中文输入With CreateObject(vbscript.regexp).Global = True.Pattern = 0-9.+If .test(t.Text) Thent.Text = .Replace(t.Text,)End IfEnd WithEnd SubPublic Sub tk(i As OLEObject)获取oleboject对象Set t = i.ObjectEnd SubDim Ar(1 To 10

14、0) As TT定义数组类Sub justest()Dim j As OLEObject, K As ByteFor Each j In Sheet1.OLEObjectsIf TypeName(j.Object) = TextBox Then如果为TEXTBOX控件j.Object.Text = 清空文本框K = K + 1: Set Ar(K) = New TT同时创建类实体Ar(K).tk j给类实体赋值，激活事件。End Sub5, 表格上的按钮telnet_zhaogang1960。 xls类模块clsCmd中代码：Public WithEvents Cmdbox As MSForm

15、s.CommandButtonPrivate Sub Cmdbox_Click()MsgBox Cmdbox.CaptionEnd Sub表格1上的ActiveX按钮控件Dim Cmd(1 To 3) As New clsCmdPrivate Sub Worksheet_Activate()Dim i As ByteFor i = 1 To 3Set Cmd(i).Cmdbox = Me.OLEObjects(CommandButton & i).ObjectNextEnd SubPrivate Sub Worksheet_Deactivate()Erase CmdEnd Sub6, 求助由代

16、码生成的控件的事件by:山菊花当光标移入某个文本框，这个文本框的背景色变为蓝色，前景改为白色类模块代码：Public WithEvents cmd As MSForms.CommandButtonPublic WithEvents mBox As MSForms.TextBoxPrivate Sub cmd_Click()Dim ctl As MSForms.ControlWith UserForm1For Each ctl In .ControlsIf TypeName(ctl) = TextBox ThenIf ctl.Name TextBox1 Then .Controls.Remove

17、 ctl.NameElself TypeName(ctl) = CommandButton ThenIf ctl.Name CommandButton1 And ctl.Name CommandButton2 Then .Controls.Remove ctl.NameEnd IfNext.CommandButton1.Enabled = True.CommandButton2.Enabled = FalseEnd WithEnd SubPrivate Sub mBox_MouseDown(ByVal Button As Integer, ByVal Shift As Integer,ByVa

18、l X As Single, ByVal Y As Single)For i = 2 To 4With UserForm1.Controls(TextBox & i).ForeColor = 0.BackColor = 16777215mBox.BackColor = 16711680mBox.ForeColor = 16777215End Sub窗体代码：Private d(1 To 4) As New cmd_ClassPrivate Sub CommandButton1_Click()For i = 1 To 3Set d(i).mBox = Frame1.Controls.Add(fo

19、rms.TextBox.1，True)With d(i).mBox.Left = 10.Top = (i - 1) * 30 + 3.Width = 70.Height = 20.Text = .NameSet d(4).cmd = Me.Controls.Add(forms.CommandButton.1，True)With d(4).cmd.Left = CommandButton2.Left.Top = CommandButton2.Top + CommandButton2.Height.Width = CommandButton2.Width.Height = CommandButto

20、n2.Height.Caption = 删除End WithCommandButton1.Enabled = FalseCommandButton2.Enabled = TrueEnd SubPrivate Sub CommandButton2_Click()For i = 2 To 4With Controls(TextBox & i)TextBox1.Value = Val(TextBox1.Value) + Val(.Value).ForeColor = 0.BackColor = 16777215End WithNextEnd Sub7，窗体键盘快盘Mytb更新类可否实现窗体键盘.xl

21、s模块1代码：Public sName As String类模块CmdArray代码：Public WithEvents cmd As MSForms.CommandButtonPrivate Sub cmd_Click()UserForm1.Controls(sName).Text = UserForm1.Controls(sName).Text & cmd.CaptionEnd Sub类模块TxtArray代码:Public WithEvents txt As MSForms.TextBoxPrivate Sub txt_MouseDown(ByVal Button As Integer,

22、 ByVal Shift As Integer,ByVal X As Single, ByVal Y As Single)sName = txt.NameEnd Sub窗体代码：Private arrCmd(0 To 10) As CmdArrayPrivate arrTxt(1 To 4) As TxtArrayPrivate Sub UserForm_Initialize()Dim i As IntegerDim cmdNew As CmdArrayDim txtNew As TxtArrayFor i = 0 To 10Set cmdNew = New CmdArraySet cmdNe

23、w.cmd = Me.Controls(CommandButton & i)Set arrCmd(i) = cmdNewSet cmdNew = NothingNextFor i = 1 To 4Set txtNew = New TxtArraySet txtNew.txt = Me.Controls(TextBox & i)Set arrTxt(i) = txtNewSet txtNew = NothingNextEnd Sub8，横道图快盘Mytb更新类类入门横道图_a371014988.xls模块1代码：Sub画线条()Dim st As Worksheet, arr As Range,

24、 tg As RangeSet st = Sheets(横道图)Set arr = st.Range(A5:A & st.Range(A65536).End(xlUp).Row)For Each tg In arrDim Li As New 类 1Li.SDate = DateValue(tg.Offset(0, 3)Li.Edate = DateValue(tg.Offset(0, 4)Li.st = stLi.target = tgLi.arr = st.Range(Cells(2, 7), st.Cells(2, 255).End(xlToLeft)If Li.line Then Deb

25、ug.Print tgNextEnd Sub类模块类1代码：取左Private m_st As WorksheetPrivate M_SDate As DatePrivate M_EDate As DatePrivate M_target As RangePrivate M_arr As RangeConst Height As Integer = 3Public Property GetEdate() As DateEdate = M_EDateEnd PropertyPublic Property LetEdate(value As Date)M_EDate = valueEnd Prop

26、ertyPublic Property GetSDate() As DateSDate = M_SDateEnd PropertyPublic Property LetSDate(value As Date)M_SDate = valueEnd PropertyPublic Property Getst() As WorksheetSet st = m_stEnd PropertyPublic Property Let st(stvalue As Worksheet)Set m_st = stvalueEnd PropertyPublic Property Get target() As Ra

27、ngeSet target = M_targetEnd PropertyPublic Property Let target(tgvalue As Range)Set M_target = tgvalueEnd PropertyPublic Property Get arr() As RangeSet arr = M_arrEnd PropertyPublic Property Let arr(value As Range)Set M_arr = valueEnd PropertyPublic Function GetDateLineLeft(ByVal StartDate As Date)

28、As SingleDim tg As Range, StartPointLeft As Single, i As IntegerFor Each tg In arrIf IsDate(tg.value) ThenIf Year(StartDate) = Year(tg.value) And Month(StartDate) =Month(tg.value) ThenIf DateValue(Year(StartDate) &- & Month(StartDate) &- &1)=DateValue(tg.Value) ThenDebug.Print Day(StartDate)Select C

29、ase CInt(Day(StartDate)Case Is CInt(tg.Offset(1, 0)For i = 1 To tg.Offset(1, 0).Column - 1StartPointLeft = StartPointLeft +st.Columns(i).WidthNext iGetDateLineLeft = StartPointLeft +(CInt(Day(StartDate) Mod 10) * st.Columns(tg.Offset(1, 0).Column).Width / 10Case Is = CInt(tg.Offset(1, 0)For i = 1 To

30、 tg.Offset(1, 0).ColumnStartPointLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineLeft = StartPointLeft Exit FunctionCase Is CInt(tg.Offset(1, 0).Offset(0, 1)For i = 1 To tg.Offset(1, 0).Offset(0, 1).Column - 1StartPointLeft = StartPointLeft + st.Columns(i).Width Next iGetDateLineLeft =

31、 StartPointLeft + (CInt(Day(StartDate) Mod 10)* st.Columns(tg.Offset(1, 0).Offset(0,Case Is = CInt(tg.Offset(1, 0).Offset(0, 1)For i = 1 To tg.Offset(1, 0).Columnst.Columns(i).Width1).Column - 1st.Columns(i).WidthStartPointLeftStartPointLeftNext iGetDateLineLeft = StartPointLeftExit FunctionCase Is

32、CInt(tg.Offset(1, 0).Offset(0, 1).Offset(0, 1)For i = 1 To tg.Offset(1, 0).Offset(0, 1).Offset(0,StartPointLeftStartPointLeftNext iGetDateLineLeftStartPointLeft(CInt(Day(StartDate) Mod 10) * st.Columns(tg.Offset(1, 0).Offset(0, 1).Offset(0, 1).Column).Width / (CInt(tg.Offset(1, 0).Offset(0, 1).Offse

33、t(0, 1) - 20)Case Is = CInt(tg.Offset(1, 0).Offset(0, 1).Offset(0, 1)For i = 1 To tg.Offset(1, 0).ColumnStartPointLeft = StartPointLeft +st.Columns(i).WidthNext iGetDateLineLeft = StartPointLeftExit FunctionEnd SelectEnd IfEnd IfNext tgEnd Function取右顶点线条位置Public Function GetDateLineRight(ByVal EndDa

34、te As Date) As SingleDim arr As Range, tg As Range, StartPointLeft As Single, i As IntegerSet arr = st.Range(Cells(2, 7), st.Cells(2, 255).End(xlToLeft)For Each tg In arrIf IsDate(tg.value) ThenIf Year(EndDate) = Year(tg.value) And Month(EndDate) = Month(tg.value) ThenIf DateValue(Year(EndDate) & 年

35、& Month(EndDate) & 月 & 1 日)=tg.Value ThenDebug.Print Day(EndDate)Select Case CInt(Day(EndDate)Case Is CInt(tg.Offset(1, 0)For i = 1 To tg.Offset(1, 0).Column - 1StartPointLeft = StartPointLeft + st.Columns(i).WidthNext iGetDateLineRight = StartPointLeft +(CInt(Day(EndDate) Mod 10) * st.Columns(tg.Of

36、fset(1, 0).Column).Width / 10Exit FunctionCase Is = CInt(tg.Offset(1, 0)For i = 1 To tg.Offset(1, 0).ColumnStartPointLeft = StartPointLeft + st.Columns(i).WidthNext iGetDateLineRight = StartPointLeftCase Is CInt(tg.Offset(1, 0).Offset(0, 1)For i = 1 To tg.Offset(1, 0).Offset(0, 1).Column -1StartPoin

37、tLeft = StartPointLeft + st.Columns(i).WidthNext iGetDateLineRight = StartPointLeft + (CInt(Day(EndDate) Mod 10)* st.Columns(tg.Offset(1, 0).Offset(0,1).Column).Width / 10Exit FunctionCase Is = CInt(tg.Offset(1, 0).Offset(0, 1)StartPointLeftStartPointLeftst.Columns(i).WidthNext iGetDateLineRight = S

38、tartPointLeftExit FunctionCase Is CInt(tg.Offset(1, 0).Offset(0, 1).Offset(0,1)For i = 1 Totg.Offset(1, 0).Offset(0,1).Offset(0, 1).Column - 1StartPointLeftStartPointLeftst.Columns(i).WidthNext iGetDateLineRightStartPointLeft(CInt(Day(EndDate) Mod 10) * st.Columns(tg.Offset(1, 0).Offset(0, 1).Offset

39、(0, 1).Column).Width / (CInt(tg.Offset(1, 0).Offset(0, 1).Offset(0, 1) - 20)Exit Function1)For i = 1 To tg.Offset(1, 0).Offset(0, 1).Offset(0, 1).ColumnStartPointLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineRight = StartPointLeft Exit Function End Select End If End IfNext tgEnd Func

40、tionPublic Function GetLineTop(ByVal tg As Range) As SingleDim i As Integer, LineTop As SingleFor i =1 To tg.Row - 1LineTop = LineTop + st.Rows(i).HeightNext iGetLineTop = LineTop + tg.Height / 3End FunctionPublic Function GetLineHeight()GetLineHeight = HeightEnd FunctionPublic Function line() As Bo

41、oleanst.Shapes.AddShape(msoShapeRectangle,GetDateLineLeft(SDate),GetLineTop(target), GetDateLineRight(Edate) - GetDateLineLeft(SDate),GetLineHeight).SelectSelection.ShapeRange.line.ForeColor.RGB = RGB(255, 0, 0)Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0)End Function工作表按钮代码：Private Sub C

42、ommandButton1_Click()Application.Run 画线条End SubPrivate Sub CommandButton2_Click()For Each obj In Me.ShapesIf obj.Name = CommandButton1 Or obj.Name = CommandButton2 ThenElseobj.DeleteEnd IfNextEnd Sub9，类模块入门_ExcelPerfect这里简单地介绍VBA中的类模块，使大家能够在应用程序中创建并使用简单的类。类是对象的“模板”。对象可以是任何事物，而类不会做任何事情，也不会占用内存，只 有当类成

43、为对象并使用Set语句和New关键字实例化为具体对象后，才能做事情并占用内 存。实例化类为具体对象的语法为：Dim C As Class1Set C=New Classi上述语句创建了一个名为C的对象，该对象的数据类型为定义的类Classi。在详细介绍类之前，让我们先看看VBA的用户自定义数据类型，即使用Type关键字定义的变量。例如，下面的Type变量定义了雇员的信息：Type EmployeeName As StringAddress As StringSalary As DoubleEnd Type上面的语句定义了变量Employee，包含元素Name、Address和Salary。接着

44、，您可以声明一个Employee型的变量，并为其中的每个元素赋值：Sub test()Dim Fan As EmployeeFan.Name = fanjyFan.Address = YiChangFan.Salary =1000End Sub用户自定义类型是很有用的，但是有三个主要的局限：1、在编译时必须声明所有的自定义类型变量。虽然可以使用动态数组来处理多个自定义类 型，但必须使用Redim Preserve关键词。并且，不能在运行时添加新的自定义类型变量。2、不能控制赋给自定义类型中元素的值。例如，在上述代码中，有可能给Salary元素赋 一个负值。3、自定义类型不做任何事情，只是静态地存储数据。用户自定义类型被广泛用于在对Windows API函数调用时，除此之外，使用类模块是更好 的选择。类克服了用户自定义类型的局限。1、使用New关键字，可以创建任意数量的类的新实例，并且能够将其存储在Collection 对象中。2、使用Property Let/Set/Get语句，可以编写代码验证赋给类元素的值，并且可以编写 当值改变时执行的相应代码。例如，能够编写代码确保Salary的值不为负值。3、类可以定义方法（使用Sub过程和Function过程），执行某项动作。