Excel VBA類代碼實(shí)例集錦

1、1, 類動(dòng)態(tài)數(shù)組控件 2007VBA技巧快盤Mytb更新類類動(dòng)態(tài)數(shù)組控件.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) <> "" Then frm.Lab

2、el1.Caption = "控件事件：Change" & vbCrLf & _ "控件名稱：" & frm.Controls("Textbox" & Index).Name & vbCrLf & _ "Text屬性：" & frm.Controls("Textbox" & Index).TextEnd IfEnd SubPrivate Sub myText_DblClick(ByVal Cancel As MSForms.Retu

3、rnBoolean)Index = Mid(myText.Name, 8)If frm.Controls("Textbox" & Index) <> "" Then frm.Label1.Caption = "控件事件：DblClick" & vbCrLf & _ "控件名稱：" & frm.Controls("Textbox" & Index).Name & vbCrLf & _ "Cancel屬性：" &

4、amp; 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.Label1.Caption = "控件事件：KeyUp" & vbCrLf &

5、; _ "控件名稱：" & frm.Controls("Textbox" & Index).Name & vbCrLf & _ "按鍵值：&H" & Hex$(KeyCode)End IfEnd SubPrivate Sub myText_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)Select Case IndexCase 3 Userfo

6、rm2.Label2.Caption = "3"Case 8Userform2.Label2.Caption = "8"Case 4 Userform2.Label2.Caption = "4"Case 9 Userform2.Label2.Caption = "9"Case Else Userform2.Label2.Caption = " "End SelectEnd Sub模塊1代碼：Public a(1 To 14) As myTextSub formshow()Userform2.Sh

7、owEnd Sub窗體代碼：Private Sub CommandButton1_Click()Dim i&, t$For i = 1 To 14 If a(i).myText.Text <> "" Then t = t & "控件名稱：" & a(i).myText.Name & vbTab & "Text屬性：" & a(i).myText.Text & vbCrLf End IfNext iMsgBox tEnd SubPrivate Sub UserForm_

8、Initialize()Dim i&For i = 1 To 14 Set a(i) = New myText Set a(i).myText = Me.Controls("Textbox" & i) Set a(i).frm = MeNext iEnd Sub工作表代碼：Private Sub CommandButton1_Click()Userform2.ShowEnd Sub2, 復(fù)選框選擇 快盤Mytb更新類類0928.xls當(dāng)復(fù)選框選擇到7個(gè)時(shí)，其它的復(fù)選框不能再選擇。當(dāng)復(fù)選框選擇小于7個(gè)，其它的復(fù)選框還能繼續(xù)選擇。類模塊代碼：Public Wit

9、hEvents che As MSForms.CheckBoxPublic WithEvents frm As MSForms.UserFormPrivate Sub che_Change() '類的數(shù)據(jù)改變事件 Dim index As Long index = Mid(che.Name, 9) '取出checkboxN中的數(shù)字N If frm.Controls("checkbox" & index) = True Then a = a & Format(index, "00") & ","

10、n = n + 1 If n = 7 Then For i = 1 To 18 b = Format(i, "00") If InStr(a, b) = 0 Then frm.Controls("checkbox" & i).Enabled = False End If Next Else End If Else n = n - 1 a = Replace(a, Format(index, "00"), "") For i = 1 To 18 frm.Controls("checkbox"

11、; & i).Enabled = True Next End IfEnd Sub模塊1代碼：Public newclass(1 To 18) As che類, n&, a$Sub formshow()UserForm1.ShowEnd Sub窗體代碼：Private Sub UserForm_Initialize() For i = 1 To 18 Set newclass(i) = New che類 '創(chuàng)建一個(gè)新的che類對象 Set newclass(i).che = Controls("checkbox" & i) '設(shè)置新類和

12、checkbox(i)控件創(chuàng)建關(guān)鍵 Set newclass(i).frm = Me '類窗體也和當(dāng)前窗體建立關(guān)聯(lián) Next End Sub3, 限制多個(gè)TEXTBOX的輸入，使其只能輸入數(shù)值 快盤Mytb更新類如何限制多個(gè)TEXTBOX的輸入_zhaogang1980.xls6447-1-1.html類模塊代碼：Public WithEvents Txtbox As MSForms.TextBoxPrivate Sub Txtbox_Change() With CreateObject("vbscript.regexp") .Global = True .Patt

13、ern = "0-9.+" If .test(Txtbox.Text) Then Txtbox.Text = .Replace(Txtbox.Text, "") End If End WithEnd Sub模塊1代碼：Sub Macro1()UserForm1.ShowEnd Sub窗體代碼：Dim Txt() As New clsTxtPrivate Sub UserForm_Initialize() Dim ctl As Control, m& For Each ctl In Me.Controls If TypeName(ctl) = &q

14、uot;TextBox" Then If ctl.Name <> "TextBox1" Then m = m + 1 ReDim Preserve Txt(1 To m) Set Txt(m).Txtbox = ctl End If End If NextEnd SubPrivate Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) '第一個(gè)不需要類模塊 If TextBox1.Text = "" Then Exit Sub If IsDate(TextBox1

15、.Text) = False Then Cancel = True TextBox1.Text = "" End IfEnd Sub4，限制輸入字母 8095-1-1-14725.htmlPrivate WithEvents t As MSForms.TextBoxPrivate Sub t_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)'限制只可以輸入數(shù)字，不可輸入字母和其他符號Select Case KeyAsciiCase 48 To 57Case 46 If InStr(1, t.Text, ".

16、") Then KeyAscii = 0 End IfCase Else KeyAscii = 0End SelectEnd SubPrivate 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) Then t.Text = .Replace(t.Te

17、xt, "") End IfEnd WithEnd SubPublic Sub tk(i As OLEObject)'獲取oleboject對象Set t = i.ObjectEnd SubDim Ar(1 To 100) As TT'定義數(shù)組類Sub justest()Dim j As OLEObject, K As ByteFor Each j In Sheet1.OLEObjects If TypeName(j.Object) = "TextBox" Then '如果為TEXTBOX控件 j.Object.Text = &q

18、uot;" '清空文本框 K = K + 1: Set Ar(K) = New TT '同時(shí)創(chuàng)建類實(shí)體 Ar(K).tk j '給類實(shí)體賦值，激活事件。 End IfNextEnd Sub5，表格上的按鈕 telnet_zhaogang1960。xls類模塊clsCmd中代碼：Public WithEvents Cmdbox As MSForms.CommandButtonPrivate Sub Cmdbox_Click() MsgBox Cmdbox.CaptionEnd Sub表格1上的ActiveX按鈕控件Dim Cmd(1 To 3) As New c

19、lsCmdPrivate Sub Worksheet_Activate() Dim i As Byte For i = 1 To 3 Set Cmd(i).Cmdbox = Me.OLEObjects("CommandButton" & i).Object NextEnd SubPrivate Sub Worksheet_Deactivate() Erase CmdEnd Sub6, 求助由代碼生成的控件的事件 by:山菊花當(dāng)光標(biāo)移入某個(gè)文本框，這個(gè)文本框的背景色變?yōu)樗{(lán)色，前景改為白色7834-1-1.html類模塊代碼：Public WithEvents cmd

20、As MSForms.CommandButtonPublic WithEvents mBox As MSForms.TextBoxPrivate Sub cmd_Click() Dim ctl As MSForms.Control With UserForm1 For Each ctl In .Controls If TypeName(ctl) = "TextBox" Then If ctl.Name <> "TextBox1" Then .Controls.Remove ctl.Name ElseIf TypeName(ctl) = &qu

21、ot;CommandButton" Then If ctl.Name <> "CommandButton1" And ctl.Name <> "CommandButton2" Then .Controls.Remove ctl.Name End If Next .CommandButton1.Enabled = True .CommandButton2.Enabled = False End With End SubPrivate Sub mBox_MouseDown(ByVal Button As Integer, B

22、yVal Shift As Integer, ByVal X As Single, ByVal Y As Single) For i = 2 To 4 With UserForm1.Controls("TextBox" & i) .ForeColor = 0 .BackColor = 16777215 End With Next mBox.BackColor = 16711680 mBox.ForeColor = 16777215End Sub窗體代碼：Private d(1 To 4) As New cmd_ClassPrivate Sub CommandButt

23、on1_Click() For i = 1 To 3 Set d(i).mBox = Frame1.Controls.Add("forms.TextBox.1", , True) With d(i).mBox .Left = 10 .Top = (i - 1) * 30 + 3 .Width = 70 .Height = 20 .Text = .Name End With Next i Set d(4).cmd = Me.Controls.Add("forms.CommandButton.1", , True) With d(4).cmd .Left =

24、 CommandButton2.Left .Top = CommandButton2.Top + CommandButton2.Height .Width = CommandButton2.Width .Height = CommandButton2.Height .Caption = "刪除" End With CommandButton1.Enabled = False CommandButton2.Enabled = TrueEnd SubPrivate Sub CommandButton2_Click() For i = 2 To 4 With Controls(&

25、quot;TextBox" & i) TextBox1.Value = Val(TextBox1.Value) + Val(.Value) .ForeColor = 0 .BackColor = 16777215 End With NextEnd Sub7，窗體鍵盤 快盤Mytb更新類可否實(shí)現(xiàn)窗體鍵盤.xls模塊1代碼：Public sName As String類模塊CmdArray代碼：Public WithEvents cmd As MSForms.CommandButtonPrivate Sub cmd_Click() UserForm1.Controls(sName

26、).Text = UserForm1.Controls(sName).Text & cmd.CaptionEnd Sub類模塊TxtArray代碼：Public WithEvents txt As MSForms.TextBoxPrivate Sub txt_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) sName = txt.NameEnd Sub窗體代碼：Private arrCmd(0 To 10) As CmdArrayPrivat

27、e arrTxt(1 To 4) As TxtArrayPrivate Sub UserForm_Initialize() Dim i As Integer Dim cmdNew As CmdArray Dim txtNew As TxtArray For i = 0 To 10 Set cmdNew = New CmdArray Set cmdNew.cmd = Me.Controls("CommandButton" & i) Set arrCmd(i) = cmdNew Set cmdNew = Nothing Next For i = 1 To 4 Set t

28、xtNew = New TxtArray Set txtNew.txt = Me.Controls("TextBox" & i) Set arrTxt(i) = txtNew Set txtNew = Nothing NextEnd Sub8，橫道圖 快盤Mytb更新類類入門橫道圖_a371014988.xls模塊1代碼：Sub 畫線條() Dim st As Worksheet, arr As Range, tg As Range Set st = Sheets("橫道圖") Set arr = st.Range("A5:A"

29、; & st.Range("A65536").End(xlUp).Row) For Each tg In arr Dim Li As New 類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) If Li.line Then Debug.Print tg NextEnd Sub類模塊類1代碼：

30、'取左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 Get Edate() As Date Edate = M_EDateEnd PropertyPublic Property Let Edate(value As Date) M_EDate = valueEnd PropertyPublic Property G

31、et SDate() As Date SDate = M_SDateEnd PropertyPublic Property Let SDate(value As Date) M_SDate = valueEnd PropertyPublic Property Get st() As Worksheet Set st = m_stEnd PropertyPublic Property Let st(stvalue As Worksheet) Set m_st = stvalueEnd PropertyPublic Property Get target() As Range Set target

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

33、Dim tg As Range, StartPointLeft As Single, i As Integer For Each tg In arr If IsDate(tg.value) Then If Year(StartDate) = Year(tg.value) And Month(StartDate) = Month(tg.value) Then 'If DateValue(Year(StartDate) & "-" & Month(StartDate) & "-" & "1") =

34、DateValue(tg.Value) Then Debug.Print Day(StartDate) Select Case CInt(Day(StartDate) Case Is < CInt(tg.Offset(1, 0) For i = 1 To tg.Offset(1, 0).Column - 1 StartPointLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineLeft = StartPointLeft + (CInt(Day(StartDate) Mod 10) * st.Columns(tg.O

35、ffset(1, 0).Column).Width / 10 Exit Function Case Is = CInt(tg.Offset(1, 0) For i = 1 To tg.Offset(1, 0).Column StartPointLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineLeft = StartPointLeft Exit Function Case Is < CInt(tg.Offset(1, 0).Offset(0, 1) For i = 1 To tg.Offset(1, 0).Offs

36、et(0, 1).Column - 1 StartPointLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineLeft = StartPointLeft + (CInt(Day(StartDate) Mod 10) * st.Columns(tg.Offset(1, 0).Offset(0, 1).Column).Width / 10 Exit Function Case Is = CInt(tg.Offset(1, 0).Offset(0, 1) For i = 1 To tg.Offset(1, 0).Column

37、StartPointLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineLeft = StartPointLeft Exit Function Case Is < CInt(tg.Offset(1, 0).Offset(0, 1).Offset(0, 1) For i = 1 To tg.Offset(1, 0).Offset(0, 1).Offset(0, 1).Column - 1 StartPointLeft = StartPointLeft + st.Columns(i).Width Next i GetDa

38、teLineLeft = StartPointLeft + (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).Offset(0, 1) - 20) Exit Function Case Is = CInt(tg.Offset(1, 0).Offset(0, 1).Offset(0, 1) For i = 1 To tg.Offset(1, 0).Column StartPoin

39、tLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineLeft = StartPointLeft Exit Function End Select End If End If Next tgEnd Function'取右頂點(diǎn)線條位置Public Function GetDateLineRight(ByVal EndDate As Date) As Single Dim arr As Range, tg As Range, StartPointLeft As Single, i As Integer Set arr

40、= st.Range(Cells(2, 7), st.Cells(2, 255).End(xlToLeft) For Each tg In arr If IsDate(tg.value) Then If Year(EndDate) = Year(tg.value) And Month(EndDate) = Month(tg.value) Then 'If DateValue(Year(EndDate) & "年" & Month(EndDate) & "月" & "1日") = tg.Value

41、 Then Debug.Print Day(EndDate) Select Case CInt(Day(EndDate) Case Is < CInt(tg.Offset(1, 0) For i = 1 To tg.Offset(1, 0).Column - 1 StartPointLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineRight = StartPointLeft + (CInt(Day(EndDate) Mod 10) * st.Columns(tg.Offset(1, 0).Column).Widt

42、h / 10 Exit Function Case Is = CInt(tg.Offset(1, 0) For i = 1 To tg.Offset(1, 0).Column StartPointLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineRight = StartPointLeft Case Is < CInt(tg.Offset(1, 0).Offset(0, 1) For i = 1 To tg.Offset(1, 0).Offset(0, 1).Column - 1 StartPointLeft =

43、StartPointLeft + st.Columns(i).Width Next i GetDateLineRight = StartPointLeft + (CInt(Day(EndDate) Mod 10) * st.Columns(tg.Offset(1, 0).Offset(0, 1).Column).Width / 10 Exit Function Case Is = CInt(tg.Offset(1, 0).Offset(0, 1) For i = 1 To tg.Offset(1, 0).Offset(0, 1).Column StartPointLeft = StartPoi

44、ntLeft + st.Columns(i).Width Next i GetDateLineRight = StartPointLeft Exit Function Case Is < CInt(tg.Offset(1, 0).Offset(0, 1).Offset(0, 1) For i = 1 To tg.Offset(1, 0).Offset(0, 1).Offset(0, 1).Column - 1 StartPointLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineRight = StartPoint

45、Left + (CInt(Day(EndDate) Mod 10) * st.Columns(tg.Offset(1, 0).Offset(0, 1).Offset(0, 1).Column).Width / (CInt(tg.Offset(1, 0).Offset(0, 1).Offset(0, 1) - 20) Exit Function Case Is = CInt(tg.Offset(1, 0).Offset(0, 1).Offset(0, 1) For i = 1 To tg.Offset(1, 0).Offset(0, 1).Offset(0, 1).Column StartPoi

46、ntLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineRight = StartPointLeft Exit Function End Select End If End If Next tgEnd FunctionPublic Function GetLineTop(ByVal tg As Range) As Single Dim i As Integer, LineTop As Single For i = 1 To tg.Row - 1 LineTop = LineTop + st.Rows(i).Height N

47、ext i GetLineTop = LineTop + tg.Height / 3End FunctionPublic Function GetLineHeight() GetLineHeight = HeightEnd FunctionPublic Function line() As Boolean st.Shapes.AddShape(msoShapeRectangle, GetDateLineLeft(SDate), GetLineTop(target), GetDateLineRight(Edate) - GetDateLineLeft(SDate), GetLineHeight)

48、.Select Selection.ShapeRange.line.ForeColor.RGB = RGB(255, 0, 0) Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0)End Function工作表按鈕代碼：Private Sub CommandButton1_Click() Application.Run "畫線條"End SubPrivate Sub CommandButton2_Click() For Each obj In Me.Shapes If obj.Name = "Comma

49、ndButton1" Or obj.Name = "CommandButton2" Then Else obj.Delete End If NextEnd Sub9，類模塊入門_ExcelPerfect 這里簡單地介紹VBA中的類模塊，使大家能夠在應(yīng)用程序中創(chuàng)建并使用簡單的類。類是對象的“模板”。對象可以是任何事物，而類不會做任何事情，也不會占用內(nèi)存，只有當(dāng)類成為對象并使用Set語句和New關(guān)鍵字實(shí)例化為具體對象后，才能做事情并占用內(nèi)存。實(shí)例化類為具體對象的語法為：Dim C As Class1Set C=New Class1上述語句創(chuàng)建了一個(gè)名為C的對象，該對象的數(shù)據(jù)類型為定義的類Class1。在詳細(xì)介紹類之前，讓我們先看看VBA的用戶自定義數(shù)據(jù)類型，即使用Type關(guān)鍵字定義的變量。例如，下面的Type變量定義了雇員的信息：Type EmployeeName As StringAddress As StringSalary As DoubleEnd Type上面的語句定義了變量Employee，包含元素Name、Address和Salary。接著，您可以聲明一個(gè)Employee型的變量，并為其中的每個(gè)元素賦值：