本类文章的标签为 ‘Find方法’


Range对象应用大全(4)—Find方法应用大全

2009年08月16日, 8:21 下午
1 颗星2 颗星3 颗星4 颗星5 颗星 (4 人投票, 平均: 5.00 out of 5)
Loading ... Loading ...

本文整理了以前的一些关于Find方法的文章，作为Excel VBA应用大全的一部分。
1. Find方法的作用
使用VBA在工作表或单元格区域中查找某项数据时，我们通常使用For…Next循环，这在小范围中使用还可以，但应用在大量数据中查找时，会耗费较多时间。
而在Excel工作表中，通常使用菜单“编辑>>查找”命令或按Ctrl+F组合键，在“查找和替换”对话框中来迅速查找所需的数据。在VBA中，我们也能使用这种方法，即Find方法，这在下面的内容中介绍。
Find方法将在指定的单元格区域中查找包含参数指定数据的单元格，若找到符合条件的数据，则返回包含该数据的单元格；若未发现相匹配的数据，则返回Nothing。该方法返回一个Range对象，在使用该方法时，不影响选定区域或活动单元格。
为什么要使用Find方法呢？最主要的原因是查找的速度。如果要使用VBA代码在包含大量数据的单元格区域中查找某项数据，应该使用Find方法。
例如，在工作表Sheet1的单元格IV65536中输入fanjy，然后运行下面的代码：

Sub QuickSearch()
    If Not Sheet1.Cells.Find("fanjy") Is Nothing Then MsgBox "已找到fanjy!"
End Sub

再试试下面的代码：

Sub SlowSearch()
    Dim R As Range
    For Each R In Sheet1.Cells
        If R.Value = "fanjy" Then MsgBox "已找到fanjy!"
    Next R
End Sub

比较一下两段代码的速度，可知第一段代码运行很快，而第二段代码却要执行相当长的一段时间。
2. Find方法的语法
[语法]

<单元格区域>.Find (What，[After]，[LookIn]，[LookAt]，[SearchOrder]，[SearchDirection]，[MatchCase]，[MatchByte]，[SearchFormat])

[参数说明]
(1)<单元格区域>，必须指定，返回一个Range对象。
(2)参数What，必需指定。代表所要查找的数据，可以为字符串、整数或者其它任何数据类型的数据。对应于“查找与替换”对话框中，“查找内容”文本框中的内容。
(3)参数After，可选。指定开始查找的位置，即从该位置所在的单元格之后向后或之前向前开始查找(也就是说，开始时不查找该位置所在的单元格，直到Find方法绕回到该单元格时，才对其内容进行查找)。所指定的位置必须是单元格区域中的单个单元格，如果未指定本参数，则将从单元格区域的左上角的单元格之后开始进行查找。
(4)参数LookIn，可选。指定查找的范围类型，可以为以下常量之一：xlValues、xlFormulas或者xlComments，默认值为xlFormulas。对应于“查找与替换”对话框中，“查找范围”下拉框中的选项。
(5)参数LookAt，可选。可以为以下常量之一：XlWhole或者xlPart，用来指定所查找的数据是与单元格内容完全匹配还是部分匹配，默认值为xlPart。对应于“查找与替换”对话框中，“单元格匹配”复选框。
(6)参数SearchOrder，可选。用来确定如何在单元格区域中进行查找，是以行的方式(xlByRows)查找，还是以列的方式(xlByColumns)查找，默认值为xlByRows。对应于“查找与替换”对话框中，“搜索”下拉框中的选项。
(7)参数SearchDirection，可选。用来确定查找的方向，即是向前查找(XlPrevious)还是向后查找(xlNext)，默认的是向后查找。
(8)参数MatchCase，可选。若该参数值为True，则在查找时区分大小写。默认值为False。对应于“查找与替换”对话框中，“区分大小写”复选框。
(9)参数MatchByter，可选。即是否区分全角或半角，在选择或安装了双字节语言时使用。若该参数为True，则双字节字符仅与双字节字符相匹配；若该参数为False，则双字节字符可匹配与其相同的单字节字符。对应于“查找与替换”对话框中，“区分全角/半角”复选框。
(10)参数SearchFormat，可选，指定一个确切类型的查找格式。对应于“查找与替换”对话框中，“格式”按钮。当设置带有相应格式的查找时，该参数值为True。
(11)在每次使用Find方法后，参数LookIn、LookAt、SearchOrder、MatchByte的设置将保存。如果下次使用本方法时，不改变或指定这些参数的值，那么该方法将使用保存的值。
在VBA中设置的这些参数将更改“查找与替换”对话框中的设置；同理，更改“查找与替换”对话框中的设置，也将同时更改已保存的值。也就是说，在编写好一段代码后，若在代码中未指定上述参数，可能在初期运行时能满足要求，但若用户在“查找与替换”对话框中更改了这些参数，它们将同时反映到程序代码中，当再次运行代码时，运行结果可能会产生差异或错误。若要避免这个问题，在每次使用时建议明确的设置这些参数。
3. Find方法使用示例
3.1 本示例在活动工作表中查找what变量所代表的值的单元格，并删除该单元格所在的列。

Sub Find_Error()
  Dim rng As Range
  Dim what As String
  what = "Error"
  Do
    Set rng = ActiveSheet.UsedRange.Find(what)
    If rng Is Nothing Then
      Exit Do
    Else
       Columns(rng.Column).Delete
    End If
  Loop
End Sub

3.2 带格式的查找
本示例在当前工作表单元格中查找字体为”Arial Unicode MS”且颜色为红色的单元格。其中，Application.FindFormat对象允许指定所需要查找的格式，此时Find方法的参数SearchFormat应设置为True。

Sub FindWithFormat()
  With Application.FindFormat.Font
        .Name = "Arial Unicode MS"
        .ColorIndex = 3
  End With
  Cells.Find(what:="", SearchFormat:=True).Activate
End Sub

[小结] 在使用Find方法找到符合条件的数据后，就可以对其进行相应的操作了。您可以：

  • 对该数据所在的单元格进行操作；
  • 对该数据所在单元格的行或列进行操作；
  • 对该数据所在的单元格区域进行操作。

4. 与Find方法相联系的方法
可以使用FindNext方法和FindPrevious方法进行重复查找。在使用这两个方法之前，必须用Find方法指定所需要查找的数据内容。
4.1 FindNext方法
FindNext方法对应于“查找与替换”对话框中的“查找下一个”按钮。可以使用该方法继续执行查找，查找下一个与Find方法中所指定条件的数据相匹配的单元格，返回代表该单元格的Range对象。在使用该方法时，不影响选定区域或活动单元格。
4.1.1 语法

<单元格区域>.FindNext(After)

4.1.2 参数说明
参数After，可选。代表所指定的单元格，将从该单元格之后开始进行查找。开始时不查找该位置所在的单元格，直到FindNext方法绕回到该单元格时，才对其内容进行查找。所指定的位置必须是单元格区域中的单个单元格，如果未指定本参数，则将从单元格区域的左上角的单元格之后开始进行查找。
当查找到指定查找区域的末尾时，本方法将环绕至区域的开始继续查找。发生环绕后，为停止查找，可保存第一次找到的单元格地址，然后测试下一个查找到的单元格地址是否与其相同，作为判断查找退出的条件，以避免出现死循环。当然，如果在查找的过程中，将查找到的单元格数据进行了改变，也可不作此判断，如下例所示。
4.2 FindPrevious方法
可以使用该方法继续执行Find方法所进行的查找，查找前一个与Find方法中所指定条件的数据相匹配的单元格，返回代表该单元格的Range对象。在使用该方法时，不影响选定区域或活动单元格。
4.2.1 语法

<单元格区域>.FindPrevious(After)

4.2.2 参数说明
参数After，可选。代表所指定的单元格，将从该单元格之前开始进行查找。开始时不查找该位置所在的单元格，直到FindPrevious方法绕回到该单元格时，才对其内容进行查找。所指定的位置必须是单元格区域中的单个单元格，如果未指定本参数，则将从单元格区域的左上角的单元格之前开始进行查找。
当查找到指定查找区域的起始位置时，本方法将环绕至区域的末尾继续查找。发生环绕后，为停止查找，可保存第一次找到的单元格地址，然后测试下一个查找到的单元格地址是否与其相同，作为判断查找退出的条件，以避免出现死循环。
4.2.3 示例
在工作表中输入如下图1所示的数据，至少保证在A列中有两个单元格输入了数据“excelhome”。
find1 图1：测试的数据
在VBE编辑器中输入下面的代码测试Find方法、FindNext方法、FindPrevious方法，体验各个方法所查找到的单元格位置。

Sub testFind()
  Dim findValue As Range
  Set findValue = Worksheets("Sheet1").Columns("A").Find(what:="excelhome")
  MsgBox "第一个数据发现在单元格:" & findValue.Address
  Set findValue = Worksheets("Sheet1").Columns("A").FindNext(After:=findValue)
  MsgBox "下一个数据发现在单元格:" & findValue.Address
  Set findValue = Worksheets("Sheet1").Columns("A").FindPrevious(After:=findValue)
  MsgBox "前一个数据发现在单元格" & findValue.Address
End Sub

5. 综合示例
[示例1]查找值并选中该值所在的单元格
[示例1-1]

Sub Find_First()
    Dim FindString As String
    Dim rng As Range
    FindString = InputBox("请输入要查找的值:")
    If Trim(FindString) <> "" Then
        With Sheets("Sheet1").Range("A:A")
            Set rng = .Find(What:=FindString, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not rng Is Nothing Then
                Application.Goto rng, True
            Else
                MsgBox "没有找到!"
            End If
        End With
    End If
End Sub

示例说明：运行程序后，将在工作表Sheet1的A列中查找InputBox函数输入框中所输入的值，并查找该值所在的第一个单元格，如果没有找到该值，则显示消息框“没有找到!”。语句Application.Goto rng, True的作用是将窗口滚动至该单元格，即该单元格位于当前窗口的左上方。
[示例1-2]

Sub Find_Last()
    Dim FindString As String
    Dim rng As Range
    FindString = InputBox("请输入要查找的值")
    If Trim(FindString) <> "" Then
        With Sheets("Sheet1").Range("A:A")
            Set rng = .Find(What:=FindString, _
                            After:=.Cells(1), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False)
            If Not rng Is Nothing Then
                Application.Goto rng, True
            Else
                MsgBox "Nothing found"
            End If
        End With
  End If
End Sub

示例说明：与上面的程序不同的是，运行该程序后，将在工作表Sheet1的A列中查找InputBox函数输入框中所输入的值，并选中该值所在的最后一个单元格。请比较代码中Find方法的参数。
[示例1-3]

Sub Find_Todays_Date()
    Dim FindString As Date
    Dim rng As Range
    FindString = Date
    With Sheets("Sheet1").Range("A:A")
        Set rng = .Find(What:=FindString, _
                        After:=.Cells(.Cells.Count), _
                        LookIn:=xlFormulas, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
        If Not rng Is Nothing Then
            Application.Goto rng, True
        Else
            MsgBox "没有找到!"
        End If
    End With
End Sub

示例说明：运行程序后，将在工作表Sheet1的A列中查找日期所在的单元格，并选中第一个日期单元格。
[示例2]在B列中标出A列中有相应值的单元格

Sub Mark_cells_in_column()
    Dim FirstAddress As String
    Dim myArr As Variant
    Dim rng As Range
    Dim I As Long
 
    Application.ScreenUpdating = False
    myArr = Array("VBA")
    '也能够在数组中使用更多的值,如下所示
    'myArr = Array("VBA", "VSTO")
    With Sheets("Sheet2").Range("A:A")
 
        .Offset(0, 1).ClearContents
        '清除右侧单元格中的内容
 
        For I = LBound(myArr) To UBound(myArr)
            Set rng = .Find(What:=myArr(I), _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlFormulas, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            '如要想查找rng.value中的一部分,可使用参数值xlPart
            '如果使用LookIn:=xlValues,也会处理公式单元格中与条件相同的值
 
            If Not rng Is Nothing Then
                FirstAddress = rng.Address
                Do
                    rng.Offset(0, 1).Value = "X"
                    '如果值VBA找到,则在该单元格的右侧列中的相应单元格作上标记
                    Set rng = .FindNext(rng)
                Loop While Not rng Is Nothing And rng.Address <> FirstAddress
            End If
        Next I
    End With
    Application.ScreenUpdating = True
End Sub

示例说明：运行程序后，将查找工作表Sheet2上A列中的每个单元格，并在值为“VBA”所在的单元格的右侧单元格中作出标记“X”。
[示例3]为区域中指定值的单元格填充颜色

Sub Color_cells_in_Range()
    Dim FirstAddress As String
    Dim MySearch As Variant
    Dim myColor As Variant
    Dim rng As Range
    Dim I As Long
 
    MySearch = Array("VBA")
    myColor = Array("3")
 
    '也能在数组中使用多个值
    'MySearch = Array("VBA", "Hello", "OK")
    'myColor = Array("3", "6", "10")
 
    With Sheets("Sheet3").Range("A1:C4")
 
        '将所有单元格中的填充色改为无填充色
        .Interior.ColorIndex = xlColorIndexNone
 
         For I = LBound(MySearch) To UBound(MySearch)
            Set rng = .Find(What:=MySearch(I), _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlFormulas, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            '如果想查找rng.value的一部分,则使用参数值xlPart
            '如果使用LookIn:=xlValues,则也会处理公式单元格
 
            If Not rng Is Nothing Then
                FirstAddress = rng.Address
                Do
                    rng.Interior.ColorIndex = myColor(I)
                    Set rng = .FindNext(rng)
                Loop While Not rng Is Nothing And rng.Address <> FirstAddress
            End If
        Next I
    End With
End Sub

示例说明：运行程序后，将在工作表Sheet3上的单元格区域A1：C4中查找含有“VBA”的单元格，并将这些单元格填充为红色。如示例中的注释所提示的，也可以使用数组，将不同的值所在的单元格标记为不同的颜色。
也可以添加下面的语句，改变单元格中文本的颜色：

.Font.ColorIndex=0
.Font.ColorIndex=myColor(I)

[示例4]为工作表中指定值的单元格填充颜色

Sub Color_cells_in_Sheet()
    Dim FirstAddress As String
    Dim MySearch As Variant
    Dim myColor As Variant
    Dim rng As Range
    Dim I As Long
 
    MySearch = Array("VBA")
    myColor = Array("3")
 
    '也能在数组中使用多个值
    'MySearch = Array("VBA", "Hello", "OK")
    'myColor = Array("3", "6", "10")
 
    With Sheets("Sheet4").Cells
 
        '将所有单元格中的填充色改为无填充色
        .Interior.ColorIndex = xlColorIndexNone
 
        For I = LBound(MySearch) To UBound(MySearch)
            Set rng = .Find(What:=MySearch(I), _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlFormulas, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
           '如果想查找rng.value的一部分,则使用参数值xlPart
           '如果使用LookIn:=xlValues,则也会处理公式单元格
 
            If Not rng Is Nothing Then
                FirstAddress = rng.Address
                Do
                    rng.Interior.ColorIndex = myColor(I)
                    Set rng = .FindNext(rng)
                Loop While Not rng Is Nothing And rng.Address <> FirstAddress
            End If
        Next I
    End With
End Sub

示例说明：运行程序后，将在工作表Sheet4中查找含有“VBA”的单元格，并将这些单元格填充为红色。如示例中的注释所提示的，也可以使用数组，将不同的值所在的单元格标记为不同的颜色。
也可以添加下面的语句，改变单元格中文本的颜色：

.Font.ColorIndex=0
.Font.ColorIndex=myColor(I)

[示例5]为工作簿所有工作表中含有指定值的单元格填充颜色

Sub Color_cells_in_All_Sheets()
    Dim FirstAddress As String
    Dim MySearch As Variant
    Dim myColor As Variant
    Dim sh As Worksheet
    Dim rng As Range
    Dim I As Long
 
    MySearch = Array("ron")
    myColor = Array("3")
 
   '也能在数组中使用多个值
    'MySearch = Array("VBA", "Hello", "OK")
    'myColor = Array("3", "6", "10")
 
    For Each sh In ActiveWorkbook.Worksheets
        With sh.Cells
 
             '将所有单元格中的填充色改为无填充色
            .Interior.ColorIndex = xlColorIndexNone
 
            For I = LBound(MySearch) To UBound(MySearch)
                Set rng = .Find(What:=MySearch(I), _
                                After:=.Cells(.Cells.Count), _
                                LookIn:=xlFormulas, _
                                LookAt:=xlWhole, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlNext, _
                                MatchCase:=False)
                '如果想查找rng.value的一部分,则使用参数值xlPart
                '如果使用LookIn:=xlValues,则也会处理公式单元格
 
                If Not rng Is Nothing Then
                    FirstAddress = rng.Address
                    Do
                        rng.Interior.ColorIndex = myColor(I)
                        Set rng = .FindNext(rng)
                    Loop While Not rng Is Nothing And rng.Address <> FirstAddress
                End If
            Next I
        End With
    Next sh
End Sub

示例说明：运行程序后，将在工作簿所有工作表中查找含有“VBA”的单元格，并将这些单元格填充为红色。如示例中的注释所提示的，也可以使用数组，将不同的值所在的单元格标记为不同的颜色。
也可以添加下面的语句，改变单元格中文本的颜色：

.Font.ColorIndex=0
.Font.ColorIndex=myColor(I)

[示例6]复制相应的值到另一个工作表中

Sub Copy_To_Another_Sheet()
    Dim FirstAddress As String
    Dim MyArr As Variant
    Dim Rng As Range
    Dim Rcount As Long
    Dim I As Long
 
    Application.ScreenUpdating = False
    '也能够使用含有更多值的数组
    'myArr = Array("@", "www")
    MyArr = Array("@")
 
    Rcount = 0
    With Sheets("Sheet5").Range("A1:E10")
 
        For I = LBound(MyArr) To UBound(MyArr)
            '如果使用LookIn:=xlValues,也会处理含有"@"的公式单元格
            '注意:本示例使用xlPart而不是xlWhole

            Set Rng = .Find(What:=MyArr(I), _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlFormulas, _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                FirstAddress = Rng.Address
                Do
                    Rcount = Rcount + 1
                    '仅复制值
                    Sheets("Sheet6").Range("A" & Rcount).Value = Rng.Value
                    Set Rng = .FindNext(Rng)
                Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
            End If
        Next I
    End With
End Sub

示例说明：运行程序后，将在工作表Sheet5的单元格区域A1:E10中查找带有“@”的单元格，即e-mail地址，然后将这些单元格值依次复制到工作表Sheet6的A列中。注意，本例中使用参数值为xlPart，并且仅复制单元格值，即不带格式。
[示例7]在当前工作表的单元格区域A1:A50中输入数据5和其它的一些数据，然后在VBE编辑器中输入下面的代码。运行后，程序将在单元格A1:A50区域中查找数值5所在的单元格，并在所找到的单元格中画一个蓝色的椭圆。

Sub FindSample1()
  Dim Cell As Range, FirstAddress As String
  With Worksheets(1).Range("A1:A50")
    Set Cell = .Find(5)
    If Not Cell Is Nothing Then
       FirstAddress = Cell.Address
       Do
         With Worksheets(1).Ovals.Add(Cell.Left, _
                                      Cell.Top, Cell.Width, _
                                      Cell.Height)
                                 .Interior.Pattern = xlNone
                                 .Border.ColorIndex = 5
         End With
         Set Cell = .FindNext(Cell)
         Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
    End If
  End With
End Sub

[示例8]在一个列表中复制相关数据到另一个列表
本程序的功能是，根据单元格I1中的值，在单元格区域A1:D11中的B列进行查找，每次找到相应的值，就将该单元格所在区域的行数据复制到以单元格G3(该单元格命名为found)开始的区域中。原数据如下图2所示。
find2
图2：原始数据
点击工作表中的“查找”按钮，运行后的结果如下图3所示。
find3
图3：运行后的结果
源程序代码清单及相关说明如下：

Option Explicit
Sub FindSample2()
  Dim ws As Worksheet
  Dim rgSearchIn As Range
  Dim rgFound As Range
  Dim sFirstFound As String
  Dim bContinue As Boolean
 
  ReSetFoundList '初始化要复制的列表区域
  Set ws = ThisWorkbook.Worksheets("sheet1")
  bContinue = True
  Set rgSearchIn = GetSearchRange(ws) '获取查找区域
  
  '设置查找参数
  Set rgFound = rgSearchIn.Find(what:=ws.Range("I1").Value, _
             LookIn:=xlValues, LookAt:=xlWhole)
 
  '获取第一个满足条件的单元格地址,作为结束循环的条件
  If Not rgFound Is Nothing Then sFirstFound = rgFound.Address
 
  Do Until rgFound Is Nothing Or Not bContinue
    CopyItem rgFound
    Set rgFound = rgSearchIn.FindNext(rgFound)
    '判断循环是否中止
    If rgFound.Address = sFirstFound Then bContinue = False
  Loop
 
  Set rgSearchIn = Nothing
  Set rgFound = Nothing
  Set ws = Nothing
End Sub
 
'获取查找区域,即B列中的"部位"单元格区域
Private Function GetSearchRange(ws As Worksheet) As Range
  Dim lLastRow As Long
  lLastRow = ws.Cells(65536, 1).End(xlUp).Row
  Set GetSearchRange = ws.Range(ws.Cells(1, 2), ws.Cells(lLastRow, 2))
End Function
 
'复制查找到的数据到found区域
Private Sub CopyItem(rgItem As Range)
  Dim rgDestination As Range
  Dim rgEntireItem As Range
 
  '获取在查找区域中的整行数据
  Set rgEntireItem = rgItem.Offset(0, -1)
  Set rgEntireItem = rgEntireItem.Resize(1, 4)
 
  Set rgDestination = rgItem.Parent.Range("found")
  '定位要复制到的found区域的第一行
  If IsEmpty(rgDestination.Offset(1, 0)) Then
    Set rgDestination = rgDestination.Offset(1, 0)
  Else
    Set rgDestination = rgDestination.End(xlDown).Offset(1, 0)
  End If
 
  '复制找到的数据到found区域
  rgEntireItem.Copy rgDestination
 
  Set rgDestination = Nothing
  Set rgEntireItem = Nothing
End Sub
 
'初始化要复制到的区域(found区域)
Private Sub ReSetFoundList()
  Dim ws As Worksheet
  Dim lLastRow As Long
  Dim rgTopLeft As Range
  Dim rgBottomRight As Range
 
  Set ws = ThisWorkbook.Worksheets("sheet1")
  Set rgTopLeft = ws.Range("found").Offset(1, 0)
  lLastRow = ws.Range("found").End(xlDown).Row
  Set rgBottomRight = ws.Cells(lLastRow, rgTopLeft.Offset(0, 3).Column)
 
  ws.Range(rgTopLeft, rgBottomRight).ClearContents
 
  Set rgTopLeft = Nothing
  Set rgBottomRight = Nothing
  Set ws = Nothing
End Sub

在上述程序代码中，程序FindSample2( )为主程序，首先调用子程序ReSetFoundList( )对所要复制到的数据区域初始化，即清空除标题行以外的内容；然后调用自定义函数GetSearchRange(ws As Worksheet)获取所在查找的单元格区域；在主程序中使用Find方法和FIndNext方法进行查找，调用带参数的子程序CopyItem(rgItem As Range)将查找到的单元格所在的数据行复制到相应的区域。
[示例9]实现带连续单元格区域条件的查找
下面的代码提供了一种实现以连续单元格区域中的数据为查找条件进行查找的方法和思路。在本例中，所查找条件区域为D2:D4，在单元格区域A1:A21中进行查找，将结果输入到以单元格F2开始的区域中。示例程序所对应的工作表数据及结果如下图4所示。

Sub FindGroup()
  Dim ToFind As Range, Found As Range, c As Range
  Dim FirstAddress As String
  Set ToFind = Range("D2:D4")
  With Worksheets(1).Range("a1:a21")
    Set c = .Find(ToFind(1), LookIn:=xlValues)
    If Not c Is Nothing Then
      FirstAddress = c.Address
      Do
        If c.Offset(1) = ToFind(2) And c.Offset(2) = ToFind(3) Then
          Set Found = Range(c.Offset(0, 1), c.Offset(0, 1).Offset(2))
          GoTo Exits
        End If
        Set c = .FindNext(c)
      Loop While Not c Is Nothing And c.Address <> FirstAddress
    End If
  End With
Exits:
  Found.Copy Range("F2")
End Sub

find4 图4：数据及查找结果
[示例10]本示例所列程序将在工作簿的所有工作表中查找数值，提供了采用两种方法编写的程序，一种是Find方法，另一种是SpecialCells 方法。相对来说，使用Find方法比使用SpecialCells方法要快，当然，本示例可能不明显，但对于带大量工作表和数据的工作簿来说，这种速度差异就可以看出来了。
示例代码如下，代码中有简要的说明。

'- - -使用Find方法 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Sub QuickSearch()
  Dim wks As Excel.Worksheet
  Dim rCell As Excel.Range
  Dim szFirst As String
  Dim i As Long
  '设置变量决定是否加亮显示查找到的单元格
  '该变量为真时则加亮显示
  Dim bTag As Boolean
  bTag = True
  '使用input接受查找条件的输入
  Dim szLookupVal As String
  szLookupVal = InputBox("在下面的文本框中输入您想要查找的值", "查找输入框", "")
 
  '如果没有输入任何数据,则退出程序
  If szLookupVal = "" Then Exit Sub
 
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
 
  ' =============================================================
  ' 添加一个工作表,在该工作表中放置已查找到的单元格地址
  ' 如果该工作表存在,则先删除它
    For Each wks In ActiveWorkbook.Worksheets
      If wks.Name = "查找结果" Then
        wks.Delete
      End If
    Next wks
 
  ' 添加工作表
    Sheets.Add ActiveSheet
  ' 重命名所添加的工作表
    ActiveSheet.Name = "查找结果"
  ' 在新增工作表中添加标题,指明所查找的值
    With Cells(1, 1)
      .Value = "已在下面所列出的位置找到数值" & szLookupVal
      .EntireColumn.AutoFit
      .HorizontalAlignment = xlCenter
    End With
 
  ' =============================================================
  ' 定位到刚开始的工作表
    ActiveSheet.Next.Select
 
  ' =============================================================
  ' 提示您是否想高亮显示已查找到的单元格
    If MsgBox("您想加阴影高亮显示所有查找到的单元格吗?", vbYesNo, _
              "加阴影高亮显示单元格") = vbNo Then
    ' 如果不想加阴影显示单元格,则将变量bTag值设置为False
      bTag = False
    End If
 
  ' =============================================================
    i = 2
  ' 开始在工作簿的所有工作表中搜索
    For Each wks In ActiveWorkbook.Worksheets
  ' 检查所有的单元格,Find方法比SpecialCells方法更快
      With wks.Cells
        Set rCell = .Find(szLookupVal, , , xlWhole, xlByColumns, xlNext, False)
        If Not rCell Is Nothing Then
          szFirst = rCell.Address
          Do
           ' 添加找到的单元格地址到新工作表中
            rCell.Hyperlinks.Add Sheets("查找结果").Cells(i, 1), "", "'" & wks.Name & "'!" & rCell.Address
           '  检查条件判断值bTag,以决定是否加亮显示单元格
             Select Case bTag
                    Case True
                       rCell.Interior.ColorIndex = 19
             End Select
             Set rCell = .FindNext(rCell)
             i = i + 1
          Loop While Not rCell Is Nothing And rCell.Address <> szFirst
        End If
      End With
    Next wks
 
  ' 释放内存变量
    Set rCell = Nothing
 
  ' 如果没有找到匹配的值,则移除新增工作表
    If i = 2 Then
      MsgBox "您所要查找的数值{" & szLookupVal & "}在这些工作表中没有发现", 64, "没有匹配值"
      Sheets("查找结果").Delete
    End If
 
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
 
'- - - 使用SpecialCells 方法- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Option Compare Text
Sub SlowerSearch()
    Dim wks As Excel.Worksheet
    Dim rCell As Excel.Range
    Dim i As Long
  '设置变量决定是否加亮显示查找到的单元格
  '该变量为真时则加亮显示
    Dim bTag As Boolean
    bTag = True
  '使用input接受查找条件的输入
    Dim szLookupVal As String
    szLookupVal = InputBox("在下面的文本框中输入您想要查找的值", "查找输入框", "")
 
  '如果没有输入任何数据,则退出程序
    If szLookupVal = "" Then Exit Sub
    With Application
      .ScreenUpdating = False
      .DisplayAlerts = False
      .Calculation = xlCalculationManual
 
  ' =============================================================
  ' 添加一个工作表,在该工作表中放置已查找到的单元格地址
  ' 如果该工作表存在,则先删除它
    For Each wks In ActiveWorkbook.Worksheets
      If wks.Name = "查找结果" Then
        wks.Delete
      End If
    Next wks
 
  ' 添加工作表
    Sheets.Add ActiveSheet
  ' 重命名所添加的工作表
    ActiveSheet.Name = "查找结果"
  ' 在新增工作表中添加标题,指明所查找的值
    With Cells(1, 1)
      .Value = "已在下面所列出的位置找到数值" & szLookupVal
      .EntireColumn.AutoFit
      .HorizontalAlignment = xlCenter
    End With
 
  ' =============================================================
  ' 定位到刚开始的工作表
    ActiveSheet.Next.Select
 
  ' =============================================================
    ' 提示您是否想高亮显示已查找到的单元格
    If MsgBox("您想加阴影高亮显示所有查找到的单元格吗?", vbYesNo, _
              "加阴影高亮显示单元格") = vbNo Then
    ' 如果不想加阴影显示单元格,则将变量bTag值设置为False
      bTag = False
    End If
 
  ' =============================================================
   i = 2
  ' 开始在工作簿的所有工作表中搜索
    On Error Resume Next
    For Each wks In ActiveWorkbook.Worksheets
      If wks.Cells.SpecialCells(xlCellTypeConstants).Count = 0 Then GoTo NoSpecCells
        For Each rCell In wks.Cells.SpecialCells(xlCellTypeConstants)
          DoEvents
          If rCell.Value = szLookupVal Then
           ' 添加找到的单元格地址到新工作表中
             rCell.Hyperlinks.Add Sheets("查找结果").Cells(i, 1), "", "'" & wks.Name & "'!" & rCell.Address
           '  检查条件判断值bTag,以决定是否加亮显示单元格
             Select Case bTag
                    Case True
                      rCell.Interior.ColorIndex = 19
             End Select
             i = i + 1
             .StatusBar = "查找到的单元格数为: " & i - 2
          End If
       Next rCell
NoSpecCells:
    Next wks
 
  ' 如果没有找到匹配的值,则移除新增工作表
  If i = 2 Then
    MsgBox "您所要查找的数值{" & szLookupVal & "}在这些工作表中没有发现", 64, "没有匹配值"
    Sheets("查找结果").Delete
  End If
 
  .Calculation = xlCalculationAutomatic
  .DisplayAlerts = True
  .ScreenUpdating = True
  .StatusBar = Empty
  End With
End Sub

6. 其它一些查找方法
可以使用For Each … Next语句和Like运算符进行更精确匹配的查找。例如，下列代码在单元格区域A1:A10中查找以字符“我”开头的单元格，并将其背景色变为红色。

Sub test()
  Dim Cell As Range
  For Each Cell In [A1:A10]
    If Cell Like "我*" Then
        Cell.Interior.ColorIndex = 3
    End If
  Next
End Sub

可以输入如下图5所示的数据进行测试。
find5
7. 扩展Find方法
我们能够使用Find方法查找单元格区域的数据，但是没有一个方法能够返回一个Range对象，该对象引用了含有所查找数据的所有单元格，下面提供了一个FindAll函数来实现此功能。此外，Find方法的另一个不足之处是不支持通配符字符串，下面也提供了一个WildCardMatchCells函数，返回一个Range对象，引用了与所提供的通配符字符串相匹配的单元格。通配符字符串可以是有效使用在Like运算符中的任何字符串。
7.1 FindAll函数
这个程序在参数SearchRange所代表的区域中查找所有含有参数FindWhat代表的值的单元格，SearchRange参数必须是一个单独的单元格区域对象，FindWhat参数是想要查找的值，其它参数是可选的且与Find方法的参数意思相同。
FindAll函数的代码如下：

Option Compare Text
Function FindAll(SearchRange As Range, FindWhat As Variant, _
    Optional LookIn As XlFindLookIn = xlValues, Optional LookAt As XlLookAt = xlWhole, _
    Optional SearchOrder As XlSearchOrder = xlByRows, _
    Optional MatchCase As Boolean = False) As Range
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 返回SearchRange区域中含有FindWhat所代表的值的所有单元格组成的Range对象
' 其参数与Find方法的参数相同
' 如果没有找到单元格,将返回Nothing.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  Dim FoundCell As Range
  Dim FoundCells As Range
  Dim LastCell As Range
  Dim FirstAddr As String
  With SearchRange
    Set LastCell = .Cells(.Cells.Count)
  End With
  Set FoundCell = SearchRange.Find(what:=FindWhat, after:=LastCell, _
    LookIn:=LookIn, LookAt:=LookAt, SearchOrder:=SearchOrder, MatchCase:=MatchCase)
  If Not FoundCell Is Nothing Then
    Set FoundCells = FoundCell
    FirstAddr = FoundCell.Address
    Do
      Set FoundCells = Application.Union(FoundCells, FoundCell)
      Set FoundCell = SearchRange.FindNext(after:=FoundCell)
    Loop Until (FoundCell Is Nothing) Or (FoundCell.Address = FirstAddr)
  End If
 
  If FoundCells Is Nothing Then
    Set FindAll = Nothing
  Else
    Set FindAll = FoundCells
  End If
End Function
使用上面代码的示例：
Sub TestFindAll()
    Dim SearchRange As Range
    Dim FoundCells As Range
    Dim FoundCell As Range
    Dim FindWhat As Variant
    Dim MatchCase As Boolean
    Dim LookIn As XlFindLookIn
    Dim LookAt As XlLookAt
    Dim SearchOrder As XlSearchOrder
 
    Set SearchRange = ThisWorkbook.Worksheets(1).Range("A1:L20")
    FindWhat = "A" '要查找的文本,可根据实际情况自定
    LookIn = xlValues
    LookAt = xlPart
    SearchOrder = xlByRows
    MatchCase = False
 
    Set FoundCells = FindAll(SearchRange:=SearchRange, FindWhat:=FindWhat, _
        LookIn:=LookIn, LookAt:=LookAt, SearchOrder:=SearchOrder, MatchCase:=MatchCase)
 
    If FoundCells Is Nothing Then
        Debug.Print "没有找到!"
    Else
        For Each FoundCell In FoundCells.Cells
            Debug.Print FoundCell.Address, FoundCell.Text
        Next FoundCell
    End If
 
End Sub

上面的代码中，列出了查找区域中含有所要查找的数据的所有单元格的地址以及相应文本。不仅可以找出所有含有所查找数据的单元格地址，而且也可以对这些单元格进行一系列操作，如格式化、更改数据等。
7.2 WildCardMatchCells函数
这个程序查找参数SearchRange所代表的区域中所有单元格，使用Like运算符将它们的值与参数CompareLikeString所代表的值比较。参数SearchRange必须是一个单独的区域，参数CompareLikeString是想要比较的文本的格式。该函数使用单元格的Text属性而不是Value属性。可选参数SearchOrder和MatchCase与Find方法中的参数意义相同。
该函数返回一个Range对象，该对象包含对与参数CompareLikeString相匹配的所有单元格的引用。如果没有匹配的单元格，则返回Nothing。
因为Find方法不支持通配符，程序将循环所有的单元格，因此对于包含大量数据的区域，执行时间可能是一个问题。并且，如果参数MatchCase为False或忽略该参数，文本在程序中必须被转换成大写，以便于查找时不区分大小写(即“A”=“a”)，因此，此时程序运行将更慢。
WildCardMatchCells函数的代码如下：

Function WildCardMatchCells(SearchRange As Range, CompareLikeString As String, _
    Optional SearchOrder As XlSearchOrder = xlByRows, _
    Optional MatchCase As Boolean = False) As Range
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 本程序返回文本值与通配符字符串相匹配的单元格引用
' 返回SearchRange区域中所有相匹配的单元格
' 匹配的条件是参数CompareLikeString
' 使用了VBA中的LIKE运算符
' 如果没有相匹配的单元格或指定了一个无效的参数,则返回Nothing.
'
' 参数SearchOrder指定查找的方向;逐行还是逐列(SearchOrder:=xlByRows或SearchOrder:=xlByColumns
' 参数MatchCase指定是否区分大小写(MatchCase:=True, "A" <> "a")或(MatchCase:=False,"A" = "a").
'
' 不需要在模块顶指定"Option Compare Text",如果指定的话,将不会正确执行大小写比较
'
' 执行单元格中的Text属性比较,而不是Value属性比较
' 因此,仅比较显示在屏幕中的文本,而不是隐藏在单元格中具体的值
'
' 如果参数SearchRange是nothing或多个区域,则返回Nothing.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  Dim FoundCells As Range
  Dim FirstCell As Range
  Dim LastCell As Range
  Dim RowNdx As Long
  Dim ColNdx As Long
  Dim StartRow As Long
  Dim EndRow As Long
  Dim StartCol As Long
  Dim EndCol As Long
  Dim WS As Worksheet
  Dim Rng As Range
 
' 确保参数SearchRange不是Nothing且是一个单独的区域
  If SearchRange Is Nothing Then
    Exit Function
  End If
  If SearchRange.Areas.Count > 1 Then
    Exit Function
  End If
 
  With SearchRange
    Set WS = .Worksheet
    Set FirstCell = .Cells(1)
    Set LastCell = .Cells(.Cells.Count)
  End With
 
  StartRow = FirstCell.Row
  StartCol = FirstCell.Column
  EndRow = LastCell.Row
  EndCol = LastCell.Column
 
  If SearchOrder = xlByRows Then
    With WS
      For RowNdx = StartRow To EndRow
        For ColNdx = StartCol To EndCol
          Set Rng = .Cells(RowNdx, ColNdx)
            If MatchCase = False Then
             '''''''''''''''''''''''''''''''''''
             '如果参数MatchCase是False,则将字符串转换成大写
             '执行忽略大小写的比较
             '因此,MatchCase:=False比MatchCase:=True更慢
             '''''''''''''''''''''''''''''''''''
               If UCase(Rng.Text) Like UCase(CompareLikeString) Then
                 If FoundCells Is Nothing Then
                    Set FoundCells = Rng
                 Else
                    Set FoundCells = Application.Union(FoundCells, Rng)
                 End If
               End If
              Else
                ''''''''''''''''''''''''''''''''''''''''''''''''
                ' MatchCase为真,不需要再进行大小写转换,因此更快些
                ' 这也是不需要在模块中指定"Option Compare Text"的原因
                ''''''''''''''''''''''''''''''''''''''''''''''''
                If Rng.Text Like CompareLikeString Then
                  If FoundCells Is Nothing Then
                    Set FoundCells = Rng
                  Else
                    Set FoundCells = Application.Union(FoundCells, Rng)
                  End If
                End If
            End If
        Next ColNdx
      Next RowNdx
    End With
  Else
    With WS
      For ColNdx = StartCol To EndCol
        For RowNdx = StartRow To EndRow
          Set Rng = .Cells(RowNdx, ColNdx)
          If MatchCase = False Then
            If UCase(Rng.Text) Like UCase(CompareLikeString) Then
              If FoundCells Is Nothing Then
                Set FoundCells = Rng
              Else
                Set FoundCells = Application.Union(FoundCells, Rng)
              End If
            End If
          Else
            If Rng.Text Like CompareLikeString Then
              If FoundCells Is Nothing Then
                Set FoundCells = Rng
              Else
                Set FoundCells = Application.Union(FoundCells, Rng)
              End If
            End If
          End If
        Next RowNdx
      Next ColNdx
    End With
  End If
 
  If FoundCells Is Nothing Then
    Set WildCardMatchCells = Nothing
  Else
    Set WildCardMatchCells = FoundCells
  End If
End Function

使用上面代码的示例：

Sub TestWildCardMatchCells()
    Dim SearchRange As Range
    Dim FoundCells As Range
    Dim FoundCell As Range
    Dim CompareLikeString As String
    Dim SearchOrder As XlSearchOrder
    Dim MatchCase As Boolean
 
    Set SearchRange = Range("A1:IV65000")
    CompareLikeString = "A?C*"
    SearchOrder = xlByRows
    MatchCase = True
 
    Set FoundCells = WildCardMatchCells(SearchRange:=SearchRange, CompareLikeString:=CompareLikeString, _
        SearchOrder:=SearchOrder, MatchCase:=MatchCase)
    If FoundCells Is Nothing Then
        Debug.Print "没有找到!"
    Else
        For Each FoundCell In FoundCells
          Debug.Print FoundCell.Address, FoundCell.Text
        Next FoundCell
    End If
End Sub

这样，在找到所需单元格后，就可以对这些单元格进行操作了。

相关文章

标签：, , ,
分类目录： VBA  |  1 评论  | 1,522 次阅读

Range对象应用大全(2)—找到工作表中的最后一行

2009年07月2日, 1:47 下午
1 颗星2 颗星3 颗星4 颗星5 颗星 (4 人投票, 平均: 3.75 out of 5)
Loading ... Loading ...

题注：这是在以前的博客中整理的一篇文章，收集到这里，作为Range对象应用大全的一部分。
在Excel中，如果想使用VBA在工作表的最后一行输入数据，则必须先找到最后一行的位置，而在有些情况下，已输入的数据中可能有隐藏的行，也可能最后一行的数据没有显示，也可能最后一行没有数据但存在格式。此时，该如何有效地找到最后一行呢？又如，如果想找到最后一个公式所在的行，又该如何查找？还有一些情况，比如，在第一行和最后一行之间存在着空行；各列的最后一行不相同，在工作表无数据区域中虽没有数据但已设置了格式……等等。
当然，在Excel中，有许多可以用来查找最后一行的方法，比如End(xlUp)属性、UsedRange属性、CurrentRegion属性、SpecialCells方法、以及Find方法等，这些方法可以在不同的情形下使用。但正如前面所讲述的，关键是要清楚Excel将“已使用范围”、“当前区域”、和一些常量如xlCellTypeLastCell在工作表中代表什么区域，以及您是在什么情形下查找最后一行，然后选用合适的方法，以确保找到正确的最后一行，否则，可能所找到的并不是您所想要的最后一行。
“最后一行”可能的情形
在查找最后一行时，可能是查找以下情形单元格所在的“最后一行”，即：

  • 含有公式的单元格
  • 格式化的单元格
  • 含有颜色的单元格
  • 包含数据有效性的单元格
  • 包含批注的单元格
  • 直接输入数据(文本和/或数字)的单元格
  • 由公式生成数据(文本和/或数字)的单元格
  • 直接输入数据(文本和/或数字)或者由公式生成数据(文本和/或数字)的单元格
  • 直接输入数字的单元格
  • 由公式生成数字的单元格
  • 直接输入数字或由公式生成数字的单元格
  • 直接输入文本的单元格
  • 由公式生成文本的单元格
  • 直接输入文本或由公式生成文本的单元格
  • 其它情形
  • 包含上述所有情形的单元格

此外，还需要考虑工作表中的最后一行是否被隐藏了，而哪些方法忽略隐藏的行？最后一行的单元格中的数据是否显示？这些都会影响到您是否能查找到正确的最后一行。
下面，我们来讨论查找最后一行的方法以及可能出现的一些情况。
找到最后一行的一些方法探讨
使用End属性
在Excel VBA中，使用End(xlUp)查找最后一行是最常使用且最为简单的方法，它假设有一列总会包含有数据（数字、文本和公式等），并且在该列中最后输入数据的单元格的下一行不会包含数据，因此不必担心会覆盖掉已有数据。但该方法有两个缺点：
（1）仅局限于查找指定列的最后一行。
（2）如果该列中最后一行被隐藏，那么该隐藏行将被视作最后一行。因此，在最后一行被隐藏时，其数据可能会被覆盖。但该列中间的隐藏行不会影响查找的结果。
[示例代码01]

Sub EndxlUp_OneColLastRow()
    If Range("A" & Rows.Count).End(xlUp) = Empty Then GoTo Finish
    '获取最后一行
    MsgBox "最后一行是第" & Range("A" & Rows.Count).End(xlUp).Row & "行."
    Exit Sub
Finish:
    MsgBox "没有发现公式或数据! "
End Sub

[示例代码02]

Sub NextRowInColumnUsedAsSub()
    '包含所有数据和公式，忽略隐藏的最后一行
    Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).Select
End Sub

[示例代码03]

Sub NextRowInColumnUsedAsFunction()
    '包含所有数据和公式，忽略隐藏的最后一行
    Range("A" & LastRowInColumn("A") + 1).Select
End Sub
 
Public Function LastRowInColumn(Column As String) As Long
     LastRowInColumn = Range(Column & Rows.Count).End(xlUp).Row
End Function

注意，要输入新数据的列可能与我们所查找最后一行时所使用的列不同，例如，在上例中，我们可以修改为在B列中查找该列的最后一行，而在A列相应行的下一行中输入新的数据。
使用Find方法
Find方法在当前工作表数据中进行查找，不需要指定列，也可以确保不会意外地覆盖掉已有数据。其中，参数LookIn指定所查找的类型，有三个常量可供选择，即xlValues、xlFormulas和xlComments。
(1) 常量xlFormulas将包含零值的单元格作为有数据的单元格。（当设置零值不显示时，该单元格看起来为空，但该参数仍将该单元格视为有数据的单元格）
(2) 常量xlValues将包含零值的单元格（如果设置零值不显示时）作为空白单元格，此时，若该单元格在最后一行，则Find方法会认为该单元格所在的行为空行，因此，该单元格中的内容可能会被新数据所覆盖。
[注：在Excel中，选择菜单“工具”——“选项”，在打开的“选项”对话框中，选择“视图”选项卡，将其中的“零值”前的复选框取消选中，则工作表中的零值都不会显示]
如果在参数LookIn中使用常量xlValues的话，还存在一个问题是：如果您将最后一行隐藏，则Find方法会认为倒数第二行是最后一行，此时您在最后一行的下一行输入数据，则会将实际的最后一行的数据覆盖。
您可以在隐藏最后一行与不隐藏最后一行，或者是最后一行显示零值与不显示零值时，运行下面的示例代码04，看看所得的结果有什么不同。
[示例代码04]

Sub Find_LastRowxlValues()
    On Error GoTo Finish
    '获取最后一行
    MsgBox "最后一行是第" & Cells.Find("*", _
      SearchOrder:=xlByRows, LookIn:=xlValues, _
      SearchDirection:=xlPrevious).EntireRow.Row & "行"
    Exit Sub
Finish:
    MsgBox "没有发现数值！"
End Sub

因此，在使用Find方法时，您应该考虑所选参数设置的常量，以及工作表最后一行是否有可能被隐藏或不显示零值。如果您忽视这些情况，很可能得不到您想要的结果，或者是覆盖掉已有数据。使用常量xlFormulas可以避免这个问题，如下面的示例代码05所示。
[示例代码05]

Sub Find_LastRowxlFormulas()
    On Error GoTo Finish
    '获取最后一行
    MsgBox "最后一行是第" & Cells.Find("*", _
      SearchOrder:=xlByRows, LookIn:=xlFormulas, _
      SearchDirection:=xlPrevious).EntireRow.Row & "行"
    Exit Sub
Finish:
    MsgBox "没发现数值或公式！"
End Sub

下面再列举几个示例代码。
[示例代码06]

Sub NextRowUsedAsSub()
    '选取最后一行的下一行
    Range("A" & Cells.Find("*", LookIn:=xlFormulas, SearchDirection:=xlPrevious).Row + 1).Select
End Sub

[示例代码07]

Sub NextRowUsedAsFunction()
    '选取最后一行的下一行(调用函数)
    Range("A" & LastRow + 1).Select
End Sub
 
Public Function LastRow() As Long
    '本代码包含隐藏行
    '使用常量xlFormulas，因为常量xlValues会忽略隐藏的最后一行
    LastRow = Cells.Find("*", LookIn:=xlFormulas, SearchDirection:=xlPrevious).Row
End Function

注：Find方法中，参数LookIn的默认值为xlFormulas。
使用SpecialCells方法
SpecialCells方法用于查找指定类型的值，其语法为SpecialCells(Type,Value)，有两种主要的使用方式：
（1）若参数Type仅考虑常量，则在查找时会忽略和覆盖由公式生成的任何数据，如示例代码08所示。
（2）若参数Type仅考虑由公式生成的数据，则在查找时会忽略和覆盖任何常量数据，如示例代码09所示。
如果参数Type是xlCellTypeConstants或者是xlCellTypeFormulas，则Value参数可使用常量决定哪种类型的单元格将被包含在结果中，这些常量值能组合而返回多个类型，其缺省设置是选择所有的常量或公式，而不管是何类型，可使用下面四个可选的常量：
1）xlTextValues（包含文本） 2）xlNumbers（包含数字）
3）xlErrors（包含错误值） 4）xlLogical（包含逻辑值）
自已在工作表输入一些含有数值和公式的数据，隐藏或不隐藏最后一行或公式所在的行，体验下面的两段示例代码。
[示例代码08]

'当最后一行为公式或隐藏了最后行时，会忽略，即认为倒数第二行为最后一行
Sub NextConstantRowFunction()
Range("A" & LastConstantRow(True, True, True, True) + 1).Select
End Sub
 
Public Function LastConstantRow(Optional IncludeText As Boolean, _
                               Optional IncludeNumbers As Boolean, _
                               Optional IncludeErrors As Boolean, _
                               Optional IncludeLogicals As Boolean) As Long
   Dim Text As Long, Numbers As Long, Errors As Long
Dim Logical As Long, AllTypes As Long
   If IncludeText Then Text = xlTextValues Else Text = 0
   If IncludeNumbers Then Numbers = xlNumbers Else Numbers = 0
   If IncludeErrors Then Errors = xlErrors Else Errors = 0
   If IncludeLogicals Then Logical = xlLogical Else Logical = 0
   AllTypes = Text + Numbers + Errors + Logical
   On Error GoTo Finish
   LastConstantRow = Split(Cells.SpecialCells(xlCellTypeConstants, AllTypes).Address, "$") _
       (UBound(Split(Cells.SpecialCells(xlCellTypeConstants, AllTypes).Address, "$")))
     Exit Function
Finish:
     MsgBox "没有发现数据！"
End Function

[示例代码09]

'查找含有公式的单元格所在的行，忽略该行以后的常量和隐藏的行
Sub NextFormulaRowFunction()
     Range("A" & LastFormulaRow(True, True, True, True) + 1).Select
End Sub
 
Public Function LastFormulaRow(Optional IncludeText As Boolean, _
                               Optional IncludeNumbers As Boolean, _
                               Optional IncludeErrors As Boolean, _
                               Optional IncludeLogicals As Boolean) As Long
    Dim Text As Long, Numbers As Long, Errors As Long
    Dim Logical As Long, AllTypes As Long
    If IncludeText Then Text = xlTextValues Else Text = 0
    If IncludeNumbers Then Numbers = xlNumbers Else Numbers = 0
    If IncludeErrors Then Errors = xlErrors Else Errors = 0
    If IncludeLogicals Then Logical = xlLogical Else Logical = 0
    AllTypes = Text + Numbers + Errors + Logical
    On Error GoTo Finish
    LastFormulaRow = Split(Cells.SpecialCells(xlCellTypeFormulas, AllTypes).Address, "$") _
      (UBound(Split(Cells.SpecialCells(xlCellTypeFormulas, AllTypes).Address, "$")))
    Exit Function
Finish:
    MsgBox "没有发现数据！"
End Function

下面的示例代码10忽略最后一行带有公式的单元格，即当最后一行的单元格中含有公式时，将倒数第二行作为最后一行，即只考虑直接输入到工作表中的数据。当最后一行没有公式但被隐藏时，并不影响该方法的判断。
[示例代码10]

Sub SpecialCells_LastRowxlCellTypeConstants()
   Dim MyRow As Range
   On Error GoTo Finish
   Set MyRow = Intersect([A:A], Cells. _
   SpecialCells(xlCellTypeConstants).EntireRow).EntireRow
   '获取最后一行
   MsgBox "最后一行是第" & Split(MyRow.Address, "$") _
   (UBound(Split(MyRow.Address, "$"))) & "行"
   Set MyRow = Nothing
   Exit Sub
Finish:
   MsgBox "没有发现数据！"
End Sub

注：因为上述代码使用了“Split函数”，故只适合于Office2000及以上的版本。
该方法也允许我们指定单个数据类型，诸如数字数据或文本数据，如下所示。
下面，我们查找的最后一行是仅在行中有数字（而不包含公式）的单元格的最后一行。
[示例代码11]

Sub SpecialCells_LastRowxlCellTypeNumberConstants()
   Dim MyRow As Range
   On Error GoTo Finish
   Set MyRow = Intersect([A:A], Cells. _
   SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow)
   '获取最后一行
   MsgBox "最后一行是第" & Split(MyRow.Address, "$") _
   (UBound(Split(MyRow.Address, "$"))) & "行"
   Set MyRow = Nothing
   Exit Sub
Finish:
   MsgBox "没有发现数据！"
End Sub

下面，我们查找的最后一行是仅在行中有文本（而不包含公式）的单元格的最后一行。
[示例代码12]

Sub SpecialCells_LastRowxlCellTypeTextConstants()
   Dim MyRow As Range
   On Error GoTo Finish
   Set MyRow = Intersect([A:A], Cells. _
   SpecialCells(xlCellTypeConstants, xlTextValues).EntireRow)
   '获取最后一行
   MsgBox "最后一行是第" & Split(MyRow.Address, "$") _
   (UBound(Split(MyRow.Address, "$"))) & "行"
   Set MyRow = Nothing
   Exit Sub
Finish:
   MsgBox "没有发现数据！"
End Sub

下面，我们查找的最后一行是仅在行中有公式的单元格的最后一行。
[示例代码13]

Sub SpecialCells_LastRowxlCellTypeFormulas()
   Dim MyRow As Range
   On Error GoTo Finish
   Set MyRow = Intersect([A:A], Cells. _
   SpecialCells(xlCellTypeFormulas).EntireRow).EntireRow
   '获取最后一行
   MsgBox "最后一行是第" & Split(MyRow.Address, "$") _
   (UBound(Split(MyRow.Address, "$"))) & "行"
   Set MyRow = Nothing
   Exit Sub
Finish:
   MsgBox "没有发现数据！"
End Sub

同上面所讲述的一样，我们也能使用SpecailCells方法去找到其它特定类型的单元格所在的最后一行，下面是这些常量的完整列表：
XlCellTypeAllFormatConditions (任何格式的单元格)
XlCellTypeAllValidation (带有数据有效性的单元格)
XlCellTypeBlanks (所使用区域中的空白单元格)
XlCellTypeComments (包含有批注的单元格)
XlCellTypeConstants (包含有常量的单元格)
XlCellTypeFormulas (包含有公式的单元格)
XlCellTypeLastCell (已使用区域中的最后一个单元格(看下面))
XlCellTypeSameFormatConditions (有相同格式的单元格)
XlCellTypeSameValidation (有相同数据有效性条件的单元格)
XlCellTypeVisible (工作表中所有可见的单元格)
使用UsedRange属性（及SpecialCells方法）
UsedRange方法可用于在工作表中已使用区域查找最后一行，该区域包括可能以前使用过的任何单元格，但现在其中的数据被删除了，比如目前的工作表中只有第1行至第5行共5行，其它行都无数据，但在第6行中有些单元格以前使用过（可能仅仅格式化或内容清除了，总之该行现在不含有数据），那么第6行也包含在该已使用的区域中。此外，如果最后一行被隐藏，那么使用该方法查找最后一行是无规律且不可靠的，它通常可能会得到预料不到的结果。
有时，与UsedRange属性相似的技术也能用SpecialCells方法实现，其常量xlCellTypeLastCell代表在“已使用区域”中的最后一个单元格，与UsedRange属性稍有不同的是，当您在最后一行中输入数据后，又将其删除，则此数据所在的单元格也包含在已使用的区域中，并且如果最后的行被隐藏，则将可见行的最后一行当作最后一行。下面有两段代码您可以在工作表中进行调试，看看其特点。
[示例代码14]

Sub NextUsedRowSub()
    ' 选取可见的最后一行的下一行
    Range("A" & Cells.SpecialCells(xlCellTypeLastCell).Row + 1).Select
End Sub

[示例代码15]

Sub NextUsedRowFunction()
    Range("A" & LastUsedRow + 1).Select
End Sub
 
Public Function LastUsedRow() As Long
    LastUsedRow = Cells.SpecialCells(xlCellTypeLastCell).Row
End Function

使用这里介绍的两种技术时，您一定要清楚工作表当前的状态，以找到正确的最后一行。
使用CurrentRegion属性
CurrentRegion属性返回代表单元格所在的当前区域，即四周有空行的独立区域，因此，可使用此属性查找当前区域的最后一行。但是使用其查找最后一行的一个缺点是，必须首先选取当前区域，然后进行查找。
交叉参考
在《在汇总工作表中合并多个工作表中的数据》和《将多个工作簿中的数据合并到一个工作簿》中也有查找最后一个单元格、最后一行或最后一列的优秀代码示例。
小结
正如开始所讲述的一样，使用各种方法来查找最后一行都有其优缺点，并且都能找到您想要的最后一行，关键是您要了解各种方法的特性，以及工作表的状态，以便于选择所使用的方法来找到您需要的最后一行。
上述内容可能有不准确的地方，也可能有遗漏之处，您也可以在调试中体会和改进。

相关文章

标签：, , , , , ,
分类目录： VBA  |  2 评论  | 1,255 次阅读

将多个工作簿中的数据合并到一个工作簿

2009年05月9日, 5:00 下午
1 颗星2 颗星3 颗星4 颗星5 颗星 (2 人投票, 平均: 4.50 out of 5)
Loading ... Loading ...

在MSDN文档资料库中，Microsoft Office Excel MVP Ron de Bruin提供了一些非常好的代码示例，用于将同一文件夹里的多个工作簿中某一工作表的数据合并到一个工作簿中。下面，来介绍这些实用代码，也通过这些代码来学习VBA。当然，您可以适当修改代码，使代码满足自已想要的功能。
查找单元格区域中的最后一个单元格、最后一行或最后一列
这是后面示例中要用到的通用代码，用来查找单元格区域中的最后一行、最后一列或最后一个单元格。代码如下：

Function RDB_Last(choice As Integer, rng As Range)
' 选择 1 代表最后一行.
' 选择 2 代表最后一列.
' 选择 3 代表最后一个单元格.
    Dim lrw As Long
    Dim lcol As Integer
 
    Select Case choice
 
    Case 1:
        On Error Resume Next
        RDB_Last = rng.Find(What:="*", _
                            after:=rng.Cells(1), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
        On Error GoTo 0
 
    Case 2:
        On Error Resume Next
        RDB_Last = rng.Find(What:="*", _
                            after:=rng.Cells(1), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
        On Error GoTo 0
 
    Case 3:
        On Error Resume Next
        lrw = rng.Find(What:="*", _
                       after:=rng.Cells(1), _
                       Lookat:=xlPart, _
                       LookIn:=xlFormulas, _
                       SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious, _
                       MatchCase:=False).Row
        On Error GoTo 0
 
        On Error Resume Next
        lcol = rng.Find(What:="*", _
                        after:=rng.Cells(1), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
        On Error GoTo 0
 
        On Error Resume Next
        RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
        If Err.Number > 0 Then
            RDB_Last = rng.Cells(1).Address(False, False)
            Err.Clear
        End If
        On Error GoTo 0
 
    End Select
End Function

上述函数根据参数choice的值，使用Range对象的Find方法来查找工作簿中的最后一项。参数choice用来指定单元格、列或行。
合并文件夹中所有工作簿中的单元格区域
下面的代码合并文件夹中所有工作簿中的数据，每一工作簿中的数据被依次按行放置到目标工作表中。

Sub MergeAllWorkbooks()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
 
    '文件所在的文件夹路径,可修改为相应的文件夹
    MyPath = "C:\Users\Ron\test"
 
    '路径末尾是否有反斜杠,若无则添加
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If
 
    '如果文件夹中没有Excel文件则退出
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If
 
    '使用文件夹中的Excel文件列表填充数组(myFiles)
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop
 
    '修改屏幕更新,计算模式和启用事件的状态
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    '创建带有一个工作表的新工作簿
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1
 
    '遍历数组(myFiles)中的所有文件
    If FNum > 0 Then
        For FNum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
            On Error GoTo 0
 
            If Not mybook Is Nothing Then
 
                On Error Resume Next
 
                With mybook.Worksheets(1)
                    Set sourceRange = .Range("A1:C1")
                End With
 
                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    '如果SourceRange使用了所有的列则跳过该文件
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0
 
                If Not sourceRange Is Nothing Then
 
                    SourceRcount = sourceRange.Rows.Count
 
                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "Sorry there are not enough rows in the sheet"
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else
 
                        '在列A中复制该文件的名称
                        With sourceRange
                            BaseWks.Cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = MyFiles(FNum)
                        End With
 
                        '设置目标区域(destrange)
                        Set destrange = BaseWks.Range("B" & rnum)
 
                        '从源区域(sourceRange)复制数据到目标区域(destrange)
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value
 
                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If
 
        Next FNum
        BaseWks.Columns.AutoFit
    End If
 
ExitTheSub:
    '恢复屏幕更新,计算模式和启用事件的状态
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

上述过程使用同一文件夹中每个工作簿的路径和名称填充数组。然后，遍历该数组并且对于每个源文件，检查源区域和目标区域来看是否源区域中使用的列数多于目标区域可用的列数。如果是，则跳过该工作簿文件。接下来，代码对源区域中的行进行同样的测试。如果检查或测试均通过，那么复制源工作簿的路径和名称到新工作簿的A列，将源工作簿文件中的值复制到目标工作簿中相应的区域，然后转到数组中的下一个工作簿文件进行处理。
该过程使用每个工作簿中的第一个工作表（索引值1）。要使用特定的工作表，只需改变索引值或者将索引值修改为工作表名称：

With mybook.Worksheets("工作表名称")

也可以将单元格区域A1：C1修改为自已希望的数据区域：

                With mybook.Worksheets(1)
                    Set sourceRange = .Range("A1:C1")
                End With

如果想从单元格A2开始一直复制到工作表中最后一个单元格，那么可以使用下述代码替换。此时，第一行可能是标题行。
首先，在宏的顶部添加声明：

Dim FirstCell As String

然后，添加下面的代码：

                With mybook.Worksheets(1)
                    FirstCell = "A2"
                    Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
                    '测试是否最后一个单元格的行号大于或等于第一个单元格的行号
                    If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
                        Set sourceRange = Nothing
                    End If
                End With

从所选择的工作簿中合并单元格区域
下面的代码合并指定的工作簿中的数据。

Private Declare Function SetCurrentDirectoryA Lib _
            "kernel32" (ByVal lpPathName As String) As Long
 
Sub ChDirNet(szPath As String)
    SetCurrentDirectoryA szPath
End Sub
 
Sub MergeSpecificWorkbooks()
    Dim MyPath As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim SaveDriveDir As String
    Dim FName As Variant
 
 
    '修改屏幕更新,计算模式和启用事件的状态
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    SaveDriveDir = CurDir
    '修改为文件所在的文件夹的路径
    ChDirNet "C:\Users\Ron\test"
 
    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                                        MultiSelect:=True)
    If IsArray(FName) Then
 
        '创建带有一个工作表的新工作簿
        Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
        rnum = 1
 
 
        '遍历数组(myFiles)中的所有文件
        For FNum = LBound(FName) To UBound(FName)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(FName(FNum))
            On Error GoTo 0
 
            If Not mybook Is Nothing Then
 
                On Error Resume Next
                With mybook.Worksheets(1)
                    Set sourceRange = .Range("A1:C1")
                End With
 
                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    '如果SourceRange使用了所有的列则跳过该文件
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0
 
                If Not sourceRange Is Nothing Then
 
                    SourceRcount = sourceRange.Rows.Count
 
                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "Sorry there are not enough rows in the sheet"
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else
 
                        '在列A中复制文件名称
                        With sourceRange
                            BaseWks.Cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = FName(FNum)
                        End With
 
                        '设置目标区域(destrange)
                        Set destrange = BaseWks.Range("B" & rnum)
 
                        '从源区域(sourceRange)中复制值到目标区域(destrange)
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value
 
                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If
 
        Next FNum
        BaseWks.Columns.AutoFit
    End If
 
ExitTheSub:
    '恢复屏幕更新,计算模式和启用事件的状态
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
    ChDirNet SaveDriveDir
End Sub

除了可以选择想要合并的工作簿文件外，上述代码与前面的示例介绍的代码完成相同的操作。代码中使用了ChDirNet函数，以便设置所选文件夹的开始路径。同样，也可以改变想合并的工作表和单元格区域。
合并多个工作簿中的单元格区域（逐列排列）
按逐列排列（水平）的方式将多个工作簿中的数据合并到目标工作簿中，使用下面的代码：

Sub MergeHorizontally()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceCcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim Cnum As Long, CalcMode As Long
 
    '修改为文件所在的文件夹的路径
    MyPath = "C:\Users\Ron\test"
 
    '路径末尾是否有反斜杠,若无则添加
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If
 
    '如果文件夹中没有Excel文件则退出
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If
 
    '使用文件夹中的Excel文件列表填充数组(myFiles)
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop
 
    '修改屏幕更新,计算模式和启用事件的状态
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    '创建带有一个工作表的新工作簿
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    Cnum = 1
 
    '遍历数组(myFiles)中的所有文件
    If FNum > 0 Then
        For FNum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
            On Error GoTo 0
 
            If Not mybook Is Nothing Then
 
                On Error Resume Next
                Set sourceRange = mybook.Worksheets(1).Range("A1:A10")
 
                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    '如果SourceRange使用了所有的行则跳过该文件
                    If sourceRange.Rows.Count >= BaseWks.Rows.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0
 
                If Not sourceRange Is Nothing Then
 
                    SourceCcount = sourceRange.Columns.Count
 
                    If Cnum + SourceCcount >= BaseWks.Columns.Count Then
                        MsgBox "Sorry there are not enough columns in the sheet"
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else
 
                        '在第1行中复制该文件的名称
                        With sourceRange
                            BaseWks.Cells(1, Cnum). _
                                    Resize(, .Columns.Count).Value = MyFiles(FNum)
                        End With
 
                        '设置目标单元格区域(destrange)
                        Set destrange = BaseWks.Cells(2, Cnum)
 
                        '从源区域(sourceRange)复制数据到目标区域(destrange)
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value
 
                        Cnum = Cnum + SourceCcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If
 
        Next FNum
        BaseWks.Columns.AutoFit
    End If
 
ExitTheSub:
    '恢复屏幕更新,计算模式和启用事件的状态
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
 
End Sub

使用筛选合并文件夹中多个工作簿中的单元格区域
下面的代码合并基于筛选获取的数据：

Sub MergewithAutoFilter()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim rng As Range, SearchValue As String
    Dim FilterField As Integer, RangeAddress As String
    Dim ShName As Variant, RwCount As Long
 
    '**********************************************************
    '***运行该宏前修改下面的5行代码***
    '**********************************************************

    '文件所在的文件夹路径,可修改为相应的文件夹
    MyPath = "C:\Users\Ron\test"
 
    '每个工作簿中数据所在的工作表名
    '如果想使用工作表名代替索引值则使用ShName = "Sheet1"
    '本示例中使用每个工作簿中的第一个工作表(使用了索引值)
    ShName = 1
 
    '填写筛选区域: A1 是第一列的标题,G 是单元格区域中的最后一列
    '筛选工作表中的所有行
    '也可以使用固定的区域例如A1:G2500
    RangeAddress = Range("A1:G" & Rows.Count).Address
 
    '想要筛选的字段(本示例中 1 = 列A )
    FilterField = 1
 
    '填写筛选值(如果想要相反的值则使用"<>ron")
    '或者使用通配符例如"*ron",代表以含有ron的单元格
    '或者使用"*ron*"代表ron是单元格值的一部分
    SearchValue = "ron"
 
    '**********************************************************
    '**********************************************************

 
    '路径末尾是否有反斜杠,若无则添加
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If
 
    '如果文件夹中没有Excel文件则退出
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If
 
    '使用文件夹中的Excel文件列表填充数组(myFiles)
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop
 
    '修改屏幕更新,计算模式和启用事件的状态
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    '创建带有一个工作表的新工作簿
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1
 
    '遍历数组(myFiles)中的所有文件
    If FNum > 0 Then
        For FNum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
            On Error GoTo 0
 
            If Not mybook Is Nothing Then
 
                On Error Resume Next
                '设置筛选区域
                With mybook.Worksheets(ShName)
                    Set sourceRange = .Range(RangeAddress)
                End With
 
                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                End If
                On Error GoTo 0
 
                If Not sourceRange Is Nothing Then
                    '查找BaseWks中的最后一行
                    rnum = RDB_Last(1, BaseWks.Cells) + 1
 
                    With sourceRange.Parent
                        Set rng = Nothing
 
                        '首先, 移除自动筛选(AutoFilter)
                        .AutoFilterMode = False
 
                        '筛选FilterField列中的单元格区域
                        sourceRange.AutoFilter Field:=FilterField, _
                                               Criteria1:=SearchValue
 
                        With .AutoFilter.Range
 
                            '检查是否使用自动筛选后有结果
                            RwCount = .Columns(1).Cells. _
                                      SpecialCells(xlCellTypeVisible).Cells.Count - 1
 
                            If RwCount = 0 Then
                                '没有数据,仅有标题行
                            Else
                                ' 设置不带有标题行的单元格区域
                                Set rng = .Resize(.Rows.Count - 1, .Columns.Count). _
                                          Offset(1, 0).SpecialCells(xlCellTypeVisible)
 
 
                                '在列A中复制单元格区域和文件名称
                                If rnum + RwCount < BaseWks.Rows.Count Then
                                    BaseWks.Cells(rnum, "A").Resize(RwCount).Value _
                                          = mybook.Name
                                    rng.Copy BaseWks.Cells(rnum, "B")
                                End If
                            End If
 
                        End With
 
                        '移除自动筛选(AutoFilter)
                        .AutoFilterMode = False
 
                    End With
                End If
 
                '关闭工作簿而不保存
                mybook.Close savechanges:=False
            End If
 
            '打开下一个工作簿
        Next FNum
 
        '设置新工作簿的列宽
        BaseWks.Columns.AutoFit
        MsgBox "Look at the merge results in the new workbook after you click on OK"
    End If
 
    '恢复屏幕更新,计算模式和启用事件的状态
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

更多的关于处理工作簿的情形
上文给出了四个代码示例，分别以不同的情形来处理同一文件夹中的工作簿文件。对这些示例稍作修改，能够使它们更有用，例如，如果工作簿被密码保护，那么应使用下面的语句打开工作簿：

    Set mybook = Workbooks.Open(MyPath & MyFiles(FNum), Password:="ron", _
        WriteResPassword:="ron", UpdateLinks:=0)

如果工作簿中有对其它工作簿的链接，那么设置UpdateLinks:=0将避免出现是否更新链接的消息。如果想更新链接，则使用值3。
另一种情形是合并以指定名字开头的工作簿。例如，使用下面的语句查找以week开头的所有工作簿：

    FilesInPath = Dir(MyPath & "week*.xl*")

此外，还有合并同一文件夹中的工作簿，包括子文件夹中的工作簿的情形；以及合同每一工作簿中所有工作表的情形。
示例代码工作簿下载：

RDBMerge实用程序
RDBMerge实用程序是一个加载宏，为用户提供了合并文件夹中的工作簿到新工作簿中的友好的方式。
Excel 97-2003 加载宏下载：

Excel 2007加载宏下载：

相关文章

标签：, , , ,
分类目录： VBA  |  评论  | 3,166 次阅读

使用用户窗体查找工作表中满足条件的所有记录

2009年04月27日, 12:56 下午
1 颗星2 颗星3 颗星4 颗星5 颗星 (1 人投票, 平均: 3.00 out of 5)
Loading ... Loading ...

在《链接用户窗体与工作表》一文中曾经介绍了在用户窗体中显示工作表的数据的方法。这里，将介绍另一种情况，即在用户窗体中查找工作表中满足特定条件的所有记录，这是Dick的博客中所列举的一个示例，本文稍作修改。
如下图所示，在工作表Sheet1中，姓名为“张三”的共有三条记录，在姓名右侧的文本框中输入“张三”后，将自动显示第1条记录的相关内容，然后可以单击“前一条”和“后一条”按钮来回显示相关的记录。
ViewRangeDataInUserForm
首先，使用Find方法根据查找条件查找到满足条件的所有记录，并将其赋值给Range变量。接着，使用Property Set语句创建的自定义属性将Range变量存储的记录区域传递给用户窗体。为了确保引用的记录区域与工作表中出现的顺序相同，在Find方法中使用了After参数并将其值设置为搜索区域的最后一个单元格，这样Find方法将从单元格区域的第一个单元格开始搜索。
将用户窗体命名为UPos，其中的一些控件及其名称为：姓名文本框（txtName）、工作内容文本框（txtWork）、共有记录的文本框（txtY）、第几条记录的文本框（txtX）、前一条按钮（cmdPrev）、后一条按钮（cmdNext），还有一些标签控件。
在标准模块中输入下列代码：

Sub ShowPos()
    Dim ufPos As UPos '用户窗体变量
    Dim rFound As Range '存储当前找到的单元格
    Dim rNameRange As Range '要搜索的单元格区域
    Dim sFirstAdd As String '第一个被找到的单元格的地址
    Dim rAllFound As Range '所有找到的单元格
    
    '从用户处获取数据,这里为了介绍方便采用了硬编码
    Const strName As String = "张三"
 
    Set rNameRange = Sheet1.Range("A2:A8")
 
    '查找
    Set rFound = rNameRange.Find(strName, rNameRange(rNameRange.Cells.Count), xlValues, xlWhole)
 
    '如果找到
    If Not rFound Is Nothing Then
        '存储第一个找到的单元格的地址
        sFirstAdd = rFound.Address
        '添加找到的单元格到所有找到的单元格区域中
        Set rAllFound = rFound
        '继续查找直到循环到开始处为止
        Do
            Set rFound = rNameRange.FindNext(rFound)
            If rFound.Address <> sFirstAdd Then
                Set rAllFound = Union(rAllFound, rFound)
            End If
        Loop Until rFound.Address = sFirstAdd
 
        '创建用户窗体
        Set ufPos = New UPos
 
        '传递单元格区域到用户窗体
        Set ufPos.AllFound = rAllFound
 
        ufPos.Initialize
        ufPos.Show
    Else
        MsgBox "没有找到匹配的数据!"
    End If
 
    Set ufPos = Nothing
 
End Sub

在用户窗体模块中，声明一些模块级的变量来包含传递的区域以及当前显示的区域。

Private mrAllFound As Range
Private mrCurrent As Range
 
Property Set AllFound(RHS As Range)
    Set mrAllFound = RHS
End Property

在显示用户窗体之前，要初始化该窗体，使用查找到的第一条记录填充窗体中的相应控件。

Public Sub Initialize()
    '设置当前记录为第一条记录
    If Not mrAllFound Is Nothing Then
        Set mrCurrent = mrAllFound(1)
        Me.txtName.Text = mrCurrent.Value
        Me.txtWork.Text = mrCurrent.Next.Value
        Me.txtY.Text = mrAllFound.Cells.Count
        Me.txtX.Text = 1
    End If
End Sub

前一条按钮和后一条按钮使用FindPrevious方法和FindNext方法将记录移动到合适的位置。

Private Sub cmdNext_Click()
    '设置当前单元格
    Set mrCurrent = mrAllFound.FindNext(mrCurrent)
 
    Me.txtName.Text = mrCurrent.Value
    Me.txtWork.Text = mrCurrent.Next.Value
 
    '增加计数器值
    Me.txtX.Text = Me.txtX.Text + 1
End Sub
 
Private Sub cmdPrev_Click()
    Set mrCurrent = mrAllFound.FindPrevious(mrCurrent)
    Me.txtName.Text = mrCurrent.Value
    Me.txtWork.Text = mrCurrent.Next.Value
    Me.txtX.Text = Me.txtX.Text - 1
End Sub

最后，当第几条文本框中的值变化时，启用或禁用按钮使得用户不能试图到达不存在的记录。

Private Sub txtX_Change()
    '启用/禁用按钮
    If Me.txtX.Text = 1 Then
        Me.cmdPrev.Enabled = False
    Else
        Me.cmdPrev.Enabled = True
    End If
 
    If Me.txtX.Text = Me.txtY.Text Then
        Me.cmdNext.Enabled = False
    Else
        Me.cmdNext.Enabled = True
    End If
End Sub

示例文档下载：

相关文章

标签：, , , ,
分类目录： VBA  |  评论  | 1,181 次阅读