VBA程序集
(第2辑)
*********************************************
程序6(查找)
[程序功能] 搜索值并输入到单独的工作表中。在当前工作表的列中搜索单词(“您好”)。一旦找到匹配的数据，就将其复制到另一个工作表（“搜索结果”）中。
[条件]要求有一个命名为“搜索结果”的工作表。
[程序扩展](1)可以修改程序指定需搜索的值，也可以在该处设计一个输入框用来选取或输入要搜索的值。
(2)可以修改指定当前工作表搜索的范围。
(3)程序在搜索到指定的数据后，将会把包含此数据的整行复制到指定的工作表。可以进行修改，只复制指定的数据。同时，也可以将程序应用到设定搜索条件，搜索到满足条件的数据后，将得到整条记录结果(即查找满足条件的记录)。
[程序代码]
Option Explicit
Sub FindMe()
Dim intS As Integer
Dim rngC As Range
Dim strToFind As String, FirstAddress As String
Dim wSht As Worksheet
Application.ScreenUpdating = False
intS = 1
Set wSht = Worksheets("搜索结果")
strToFind = "您好" '指定搜索的值
With ActiveSheet.Range("A1:C20") '可根据实际工作表改变范围.
Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
If Not rngC Is Nothing Then
FirstAddress = rngC.Address
Do
rngC.EntireRow.Copy wSht.Cells(intS, 1)
intS = intS + 1
Set rngC = .FindNext(rngC)
Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
End If
End With
Application.ScreenUpdating = True
End Sub
示例文档见UploadFiles/2006-6/617259916.rar
***************************************
程序7(查找)
[程序功能] 根据值插入行。在某一列中搜索某个值，当找到该值时，就插入一个空行。
[条件] 下面的程序假设在 B 列中搜索值“1”，当找到该值时，就插入一个空行。
[程序扩展] 可以改变要搜索的值，或用对话框交互。也可改变搜索的范围。
[程序代码]
Sub 根据搜索值插入行()
Dim Rng As Range
Dim findstring As String
findstring = "1" '要搜索的值，在具体应用时可根据需要改变
Set Rng = Range("B:B").Find(What:=findstring, LookAt:=xlWhole) '根据实际改变范围
While Not (Rng Is Nothing)
Rng.EntireRow.Insert
Set Rng = Range("B" & Rng.Row + 1 & ":B" & Rows.Count).Find(What:=findstring, LookAt:=xlWhole)
Wend
End Sub
示例文档见UploadFiles/2006-6/617931442.rar
**************************************
程序8
[程序说明] 在活动工作表上的某列单元格中的数据是其它工作表名，运行程序后，工作表名单元格所在的行将被复制到与单元格内容同名的工作表中。运行程序时，源数据表必须为活动工作表。
[程序扩展] 本示例提供了一个思路，即可以将源数据工作表的数据根据特定的值进行筛选，并将筛选后的结果展示在新的不同的工作表中。
示例中值在第11列，即K列，可以根据情况改为第1列或其它列。
可根据情况进一步拓展。
[程序代码]
Sub ProcessRows()
Dim lngRowSource As Long
Dim lngRowTarget As Long
Dim strStatus As String
For lngRowSource = 1 To 25
'工作表的名字在第11列,也可以随需要更改如改为第1列
strStatus = ActiveSheet.Cells(lngRowSource, 11).Value
If strStatus <> "" Then
lngRowTarget = TargetRow(Sheets(strStatus))
ActiveSheet.Range(Cells(lngRowSource, 1), Cells(lngRowSource, 15)).Copy _
Sheets(strStatus).Cells(lngRowTarget, 1)
End If
Next
End Sub
Function TargetRow(ws As Worksheet) As Long '返回第一个空行的行号
Dim lngLastRow As Long
'在第11列即K列中查找空单元格,也可以根据情况改为第1列
lngLastRow = ws.Cells(Rows.Count, 11).End(xlUp).Row
If IsEmpty(ws.Cells(lngLastRow, 11)) Then
TargetRow = 1
Else
TargetRow = lngLastRow + 1
End If
End Function
示例文档见UploadFiles/2006-6/617710918.rar
***************************************
程序9(窗体控件——列表框/组合框)
[程序功能] 对逐层分类以及与逐层分类相似结构的表格，通过列表框/组合框来实现：第一个列表框/组合框为第一层分类，第二个列表框/组合框为第一层分类选择的类别所属的分类……依此类推。
[程序扩展] (1)本示例用列表框实现，也可用组合框实现。
(2)当数据工作表不是当前表时，可对程序进行适当修改，即列表框/组合框数据引自其它的工作表。因此，可以将数据工作表作为隐藏的数据源。
[程序代码]
Option Explicit
Private Sub UserForm_Initialize()
AddFruit Range([A1], [A1].End(xlDown))
ListBox1.ListIndex = 0
With Label1
.Caption = Cells(1, 1).Value
.Font = "隶书"
End With
With Label2
.Caption = Cells(1, 2).Value
.Font = "隶书"
End With
With Label3
.Caption = Cells(1, 3).Value
.Font = "隶书"
End With
End Sub
Sub AddFruit(Data As Range)
Dim d, cel As Range
Set d = CreateObject("Scripting.Dictionary")
For Each cel In Data
On Error Resume Next
d.Add cel.Text, cel.Text
Next
ListBox1.List() = d.items
End Sub
'********************************
Private Sub ListBox1_Change()
ListBox2.Clear
AddType Range([B1], [B1].End(xlDown))
ListBox2.ListIndex = 0
ListBox3.ListIndex = -1
End Sub
Sub AddType(Data As Range)
Dim d, cel As Range
Set d = CreateObject("Scripting.Dictionary")
For Each cel In Data
If cel.Offset(, -1) = ListBox1 Then
On Error Resume Next
d.Add cel.Text, cel.Text
End If
Next
ListBox2.List() = d.items
End Sub
'********************************
Private Sub ListBox2_Change()
ListBox3.Clear
AddMake Range([C1], [C1].End(xlDown))
If ListBox2 <> "" Then ListBox3.ListIndex = 0
End Sub
Sub AddMake(Data As Range)
Dim d, cel As Range
Set d = CreateObject("Scripting.Dictionary")
For Each cel In Data
If cel.Offset(, -1) = ListBox2 Then
On Error Resume Next
d.Add cel.Text, cel.Text
End If
Next
ListBox3.List() = d.items
End Sub
示例文档见UploadFiles/2006-6/617411253.rar
***************************************
程序10(窗体控件——列表框/组合框)
[程序说明] 要求能实现连续打印。Sheet2为源数据，Sheet1为结果，在Sheet1表中，网友已用数据有效性功能根据电脑编号实现不同人员的表单显示，即在下拉列表中选择电脑编号，显示相应人员的表单。如果需要将这些表单全打印出来，数据量大的话，需要在下拉列表中一个个选，然后击工具栏上的“打印”按钮，重复操作，很费时，且容易操作错误(重选、漏选)。
[程序思路] 只能使用VBA实现，考虑用户窗体中的控件。可选用组合框或列表框，这里用的是列表框。将数据源(即电脑编号)添加到列表框，然后赋值给Sheet1中“电脑编号”区域(已命名为“computer”，即设置数据有效性的区域)，在列表框项目中循环，并实现连续打印。
[界面]一个列表框，设置为隐藏；一个按钮，用于激活列表框以实现连续打印控制。
[程序代码]
Private Sub CommandButton1_Click()
ListBox1.ListIndex = 0
End Sub
'注：ListBox1.ListIndex = 0语句不能在listBox1_Change()过程中，应在其它过程中，以激发列表框变化，从而'激活listBox_Change事件，调用事件过程中的循环语句，改变工作表中的数据，相应得到各编号表单，并打印
Private Sub listBox1_Change()
'可以用VBA语句将工作表中的值赋给列表框，本例中在属性的RowSource进行赋值
'将列表框中的数据与设值了有效性的单元格建立链接Range("computer").Value = ListBox1.Value
For j = 0 To ListBox1.ListCount - 1 '从列表框中的第一项循环至最后一项
Range("computer").Value = ListBox1.List(j) '将列表框每项数据赋值给单元格区域，工作表中产生相应表单
Sheets(1).PrintOut Copies:=1, Collate:=True '打印
Next j
Unload UserForm1 '关闭窗体
End Sub
'在ThisWorkbook中设置工作簿打开时的动作
Private Sub Workbook_Open()
UserForm1.Show
End Sub
注：load方法可以装载窗体，但窗体是隐藏的。