VBA程序集(第4辑)

VBA程序集 (第4辑) ********************************** 程序13(查找) [程序功能] 根据某列中单元格的值是否满足条件决定是删除该单元格所在的行还是保留该单元格所在的行 [程序说明] 根据A列中的值进行判断，如果不符合条件，则删除不符合条件的单元格所在的行。 [程序扩展] 可以根据实际情况对代码进行更改，如可对判断的列进行更换，可对判断的值进行更改，以满足所需功能。 注：本示例也可用工作表中的高级筛选功能实现所需结果。 [程序代码] Sub 删除行() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim lastrow As Long, r As Long lastrow = ActiveSheet.UsedRange.Rows.Count For r = lastrow To 2 Step -1 If UCase(Cells(r, 1).Value) <> "留下" Then Rows(r).Delete '可以根据实际情况将条件进行更改,以实现需求.如更改列,或比较的值等 Next r Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub 示例文档见UploadFiles/2006-6/627521432.rar ********************************** 程序14(窗体控件——文本框) [程序功能] 在界面中有多个文本框，在文本框中输入数据，当第一个文本框达到最大输入时，光标自动转移到下一个文本框。 [程序说明] 本示例在工作表中有一个按钮，单击按钮将显示一个窗体。窗体上有5个文本输入框和一个按钮，输入焦点在第一个文本框，当第一个文本框中输入完后，光标自动转入第二个文本框，依次类推，当最后一个文本框输入完成后，“确定”按钮获得焦点，单击或按回车键将文本框中的数据输入到工作表中。单击“取消”按钮将关闭窗体。 [程序代码] ‘单击工作表上的按钮，显示输入窗体 Private Sub CommandButton1_Click() UserForm1.Show End Sub *************************** ‘各文本框代码 Private Sub TextBox1_Change() EvaluateTextEntry TextBox1 End Sub Private Sub TextBox2_Change() EvaluateTextEntry TextBox2 End Sub Private Sub TextBox3_Change() EvaluateTextEntry TextBox3 End Sub Private Sub TextBox4_Change() EvaluateTextEntry TextBox4 End Sub Private Sub TextBox5_Change() EvaluateTextEntry TextBox5 End Sub ************************** ‘确定按钮代码 Private Sub DoneButton_Click() Dim NextRow As Long NextRow = Range("A65536").End(xlUp).Row + 1 With ActiveSheet .Range("A" & NextRow) = TextBox1.Text .Range("B" & NextRow) = TextBox2.Text .Range("C" & NextRow) = TextBox3.Text .Range("D" & NextRow) = TextBox4.Text .Range("E" & NextRow) = TextBox5.Text End With TextBox1 = "" TextBox2 = "" TextBox3 = "" TextBox4 = "" TextBox5 = "" TextBox1.SetFocus End Sub ************************** ‘取消按钮代码 Private Sub CancelButton_Click() Unload Me End Sub ************************** ‘输入焦点控制代码 Private Sub EvaluateTextEntry(ByVal TheTextBox) If Len(TheTextBox.Text) = TheTextBox.MaxLength Then If TheTextBox.Name = "TextBox5" Then DoneButton.SetFocus Else Me.Controls("TextBox" & Val(Mid(TheTextBox.Name, 8)) + 1).SetFocus End If End If End Sub 示例文档见UploadFiles/2006-6/627931716.rar ********************************** 程序15(对象集合) [程序说明] 本示例创建对象集合并使用所创建的集合。 [程序代码] Sub temp() Dim ws As Worksheet Dim colMySheets As New Collection Dim str As String ‘添加工作表名中带有“C”的工作表到新集合变量中 For Each ws In ActiveWorkbook.Sheets If InStr(ws.Name, "c") > 0 Then colMySheets.Add ws End If Next ws ‘显示新集合中工作表名 For Each ws In colMySheets str = str & ws.Name & vbLf Next ws MsgBox str End Sub [程序扩展] (1)‘声明所创建的集合为全局变量 Public colMySheets As New Collection ‘可以在任何地方初始化所创建的集合变量，如在Workbook_Open事件中。 Sub InitCollection() Dim i As Long ‘对新集合变量进行清理 For i = 1 To colMySheets.Count colMySheets.Remove 1 Next i ‘添加变量 colMySheets.Add ThisWorkbook.Sheets("Sheet1") colMySheets.Add ThisWorkbook.Sheets("Sheet2") End Sub (2)‘可以指定集合在任何程序中或模块中，例如，如果想将工作表名放置在窗体中的列表框中，可在窗体初始化中加入以下代码。 Private Sub UserForm_Initialize() Dim ws As Worksheet For Each ws In colMySheets ListBox1.AddItem ws.Name Next ws End Sub (3)示例工作簿使用了一个窗体来测试集合，在打开工作簿时会对工作簿进行初始化，添加新的菜单，见[过程15]创建和使用集合变量.xls。 示例文档见UploadFiles/2006-6/627893209.rar ********************************** 程序16(工作表事件) [程序说明] 在某列中输入数据，对应列自动添加代码。本示例中“关键词代码”工作表为源数据工作表，在“主表”中C列输入关键词后，相应的B列自动列出其代码。 [程序代码] Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.Count > 1 Then Exit Sub Application.EnableEvents = False If Target.Column = 3 Then On Error Resume Next Target.Offset(, -1) = Sheets("关键词代码").Columns(2).Find(What:=Target, MatchCase:=False).Offset(, -1) End If If Err > 0 Then MsgBox ("没有发现代码!") Application.EnableEvents = True End Sub 注：(1)代码须编写在“主表”工作表模块中；(2)可以用Excel公式实现，即在“主表”工作表的B列输入公式=VLOOKUP(C2,'关键词代码'!B:C,2,FALSE)，下拉即可。但如果C列中的值为空的话，将显示#N/A错误值。当然，也可以编写=IF公式消除。VBA与Excel公式各有特点。 示例文档见UploadFiles/2006-6/627966543.rar ********************************** 程序17(用户窗体与工作簿) [程序功能] 打开工作簿时只显示用户窗体。 [程序说明] 示例中包含有一个用户窗体，当工作簿打开时只显示此用户窗体，点击说明文字后，工作簿出现，用户窗体消失。 [程序扩展] 可以用在用户界面设计中，只显示用户窗体，而不显示工作簿，把工作簿当作运行后台。 [程序代码] Private Sub Workbook_Open() Application.Visible = False UserForm1.Show End Sub ********************************** Private Sub Label1_Click() Application.Visible = True Unload UserForm1 End Sub 示例文档见UploadFiles/2006-6/627130154.rar