Access911.net   |   a9BBS   |   OTaA System  
  搜索文章:  
Access911欢迎您光临  
   主页      上传      繁體版       论坛     
设为首页  |  加入收藏   
  
你现在的位置:文章索引 -> 文章分类 -> OA  
 首页|  近日更新|  下载  |  文章索引  |  搜索|  术语|  承接工程|  
 
系统正在加载内容,请耐心等待...
 
 查询
 窗体
 报表
 
 
 VBA
 函数
 ADO/DAO/ADO.NET
 API
 ADP
 安全
 发布
 OA
 ASP/ASP.NET
 其他语言
 控件
 DELPHI
 C#/.Net
 本站
 其他
 小例程
 常用软件
 参考文档
 业主作品
 网友大作
 
 
友情链接
 access911.net
 
访问人次
 1701867
 
站长 E-Mail
 net911@sina.com
 access911@gmail.com
 
RSS 订阅

显示附加信息 >>>

如何在Excel当前打开的所有工作簿中搜索某个字符串?

作者:cg1  摘自:access911.net  :cg1  更新日期:2010-6-4  浏览人次:

 

问题:

如何在当前打开的所有工作簿中搜索某个字符串?
历年的账目每个月分一个 SHEET ,有10年的账目,120个SHEET 10个EXCEL 文档,如何在这些文档中搜索一个数据?

 


回答:


Excel 没有内置上述功能,不过可以用模块来实现,代码如下,您可以将上述代码 COPY 到一个新建的模块中,将光标停留在“查找凭证号”这几个字上,然后按 F5 键运行。

Option Compare Text
Option Explicit

'在模块内使用,存放查询结果链接的工作表
Private wsHyperLink As Worksheet

'要测试本功能,请将光标停留在以下函数内,然后按 F5 键
Public Sub 查找凭证号()
    FindAllBatch "", " "
End Sub

'在当前工作簿建立一个用于存放查询结果链接的工作表
Private Function GetWsHyperLink()
On Error GoTo GetWsHyperLink_Err
    If wsHyperLink Is Nothing Then
        Set wsHyperLink = Sheets.Add
        wsHyperLink.Name = "搜索结果" & Timer
        
    Else
        Debug.Print wsHyperLink.Name
    End If
    wsHyperLink.Activate
    GetWsHyperLink = True
    
    Exit Function
GetWsHyperLink_Err:
    Select Case Err.Number
    Case 0
        '无错误
    Case -2147221080
        '-2147221080   自动化 (Automation) 错误
        '当以前生成过临时表,后来又手动删除了,将产生自动化错误

        MsgBox "您是否手动删除了查询结果表?请重新执行查询。"
        Set wsHyperLink = Nothing
    Case Else
        Debug.Print Err.Number, Err.Description
    End Select
End Function

'根据用户的输入,切分关键字,然后批量执行查找,并将查找结果写入超级链接表
Public Sub FindAllBatch(ByVal Search As String, ByVal Delimiter As String)
    Dim Prompt          As String
    Dim Title           As String
    Dim Path            As String
    Dim strSearchWord()    As String
    Dim i As Long
On Error GoTo FindAllBatch_Err

    If Search = "" Then
        Prompt = "请填写要查找的凭证号码:" & _
        vbNewLine & vbNewLine & Path & vbNewLine & vbNewLine & "多个号码用符号“" & Delimiter & "”分隔,输入总长度请不要超过200个英文字符。"
        Title = "按您输入的内容进行查找..."
        Search = InputBox(Prompt, Title, "请在这里输入凭证号码.")
        If Search = "" Then
            Exit Sub
        End If
    End If
    
    If Len(Search) > 200 Then
        MsgBox "查找的内容不允许超过200个英文字符。"
        Exit Sub
    End If
    
    '重新获取查询结果存放表
    If GetWsHyperLink() = True Then
        
    Else
        Exit Sub
    End If
    
    strSearchWord = Split(Search, Delimiter)
    
    For i = 0 To UBound(strSearchWord)
        FindAll strSearchWord(i)
    Next
    
    
    Exit Sub
FindAllBatch_Err:
    If Err <> 0 Then
        MsgBox "FindAllBatch 出现未处理错误,错误号:" & _
                Err.Number & ",错误描述:" & Err.Description & _
                "。请将上述提示告知开发人员(access911@gmail.com)。"
    End If
         
End Sub

Public Sub FindAll(Search As String)
     
    Dim wb              As Workbook
    Dim ws              As Worksheet
    Dim WsNew           As Worksheet
    Dim Cell            As Range
    Dim Prompt          As String
    Dim Title           As String
    Dim FindCell()      As String
    Dim FindSheet()     As String
    Dim FindWorkBook()  As String
    Dim FindPath()      As String
    Dim FindText()      As String
    Dim Counter         As Long
    Dim FirstAddress    As String
    Dim Path            As String
    
    '必须有搜索关键字,否则退出系统。
    If Search = "" Then
        '按道理这里可以 RAISE 错误的。
        Exit Sub
    End If
     
On Error GoTo FindAll_Err

    Application.EnableEvents = False
    Application.DisplayAlerts = False
    'Application.ScreenUpdating = False
    Application.ScreenUpdating = True
    
    For Each wb In Application.Workbooks
        For Each ws In wb.Worksheets
            '注意,这里只判断了sheet名,没有判断workbook名,因为sheet名是根据timer取的,所以重复的可能性不大
            If ws.Name <> wsHyperLink.Name Then
                '列的选择也可以用以下代码
                'ws.Range(ws.Columns(1), ws.Columns(10)).Select
                '为加快速度,只查询 A:X 列,用户可以根据需要自己添加

                With wb.Sheets(ws.Name).Range("A:X")
                    Set Cell = .Find(What:=Search, LookIn:=xlValues, LookAt:=xlPart, _
                    MatchCase:=False, SearchOrder:=xlByColumns)
                    If Not Cell Is Nothing Then
                        '撰写状态栏文本
                        'Application.StatusBar =

                        FirstAddress = Cell.address
                        Do
                            Counter = Counter + 1
                            'Debug.Print UBound(FindCell)
                            ReDim Preserve FindCell(1 To Counter)
                            ReDim Preserve FindSheet(1 To Counter)
                            ReDim Preserve FindWorkBook(1 To Counter)
                            ReDim Preserve FindPath(1 To Counter)
                            ReDim Preserve FindText(1 To Counter)
                            FindCell(Counter) = Cell.address(False, False)
                            FindText(Counter) = Cell.Text
                            FindSheet(Counter) = ws.Name
                            FindWorkBook(Counter) = wb.Name
                            FindPath(Counter) = wb.FullName
                            Set Cell = .FindNext(Cell)
                        Loop While Not Cell Is Nothing And Cell.address <> FirstAddress
                    End If
                End With
            End If
           
            '为了防止返回记录数量超过数组上限,所以每查询一个sheet写一次查询结果。
            If Counter > 0 Then
                ResultHyperLink Search, FindSheet, FindCell, FindText, FindPath, FindWorkBook
            End If
            
            ReDim FindCell(1 To 1)
            ReDim FindSheet(1 To 1)
            ReDim FindText(1 To 1)
            ReDim FindPath(1 To 1)
            ReDim FindWorkBook(1 To 1)
            Counter = 0
        Next
    Next

     
    
    If Err <> 0 Then
        Debug.Print Err.Description
    End If
    Set wb = Nothing
    Set ws = Nothing
    Set Cell = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    
    Exit Sub
FindAll_Err:
    If Err <> 0 Then
        MsgBox "FindAll 出现未处理错误,错误号:" & _
                Err.Number & ",错误描述:" & Err.Description & _
                "。请将上述提示告知开发人员(access911@gmail.com)。"
    End If
     
End Sub
 
'将查询结果写入到超级链接表中。
'注意不要把空的 FindSheet 等数组传入到本函数中,函数内部不做检测

Private Function ResultHyperLink(ByVal Search As String, _
    ByRef FindSheet As Variant, _
    ByRef FindCell As Variant, _
    ByRef FindText As Variant, _
    ByRef FindPath As Variant, _
    ByRef FindWorkBook As Variant)
    
    Dim lngMaxRow As Long
    Dim Counter As Long
On Error GoTo ResultHyperLink_Err

    lngMaxRow = wsHyperLink.UsedRange.Row + wsHyperLink.UsedRange.Rows.Count
    lngMaxRow = lngMaxRow + 1
    
    If FindWorkBook(1) = "" Then
        Exit Function
    End If
    
    With wsHyperLink
        .Cells(lngMaxRow, 1).Value = "链接地址"
        .Cells(lngMaxRow, 2).Value = "单元格内容"
        .Cells(lngMaxRow, 3).Value = "偏移取值1"
        .Cells(lngMaxRow, 4).Value = "偏移取值2"
        .Cells(lngMaxRow, 5).Value = "找到内容"
        With .Columns("A:A")
            .ColumnWidth = 50
            .VerticalAlignment = xlTop
        End With
        With .Columns("B:B")
            .ColumnWidth = 50
            .VerticalAlignment = xlCenter
            .WrapText = True
        End With
        
        '添加超级链接表
        For Counter = 1 To UBound(FindCell)
            .Hyperlinks.Add _
                Anchor:=.Range("A" & Counter + lngMaxRow), _
                address:=FindPath(Counter), _
                SubAddress:="'" & FindSheet(Counter) & "'" & "!" & FindCell(Counter), _
                TextToDisplay:=FindWorkBook(Counter) & "-" & FindSheet(Counter) & " - " & FindCell(Counter)
            .Range("A" & Counter + lngMaxRow).Activate
            .Range("C" & Counter + lngMaxRow).Value = _
                Workbooks(FindWorkBook(Counter)).Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, 1)
            .Range("D" & Counter + lngMaxRow).Value = _
                Workbooks(FindWorkBook(Counter)).Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, 2)
            .Range("E" & Counter + lngMaxRow).Value = Search
            .Range("B" & Counter + lngMaxRow).NumberFormatLocal = "@"
            .Range("B" & Counter + lngMaxRow).Value = FindText(Counter)
            MarkText "B" & Counter + lngMaxRow, Search
        Next Counter
    End With
    
    
    Exit Function
ResultHyperLink_Err:
    If Err <> 0 Then
        MsgBox "ResultHyperLink 出现未处理错误,错误号:" & _
                Err.Number & ",错误描述:" & Err.Description & _
                "。请将上述提示告知开发人员(access911@gmail.com)。"
    End If
End Function

 
'用红色表示指定地址值中符合条件的文本
Private Sub MarkText(ByVal address As String, ByVal Search As String)
    Dim i As Long
    Dim lngStart As Long
On Error GoTo MarkText_Err
    If Range(address).Value = "101" Then
        Debug.Print Search
    End If
    
    For i = 1 To Len(Range(address).Value)
        lngStart = InStr(i, CStr(Range(address).Value), Search, 1)
        If lngStart = 0 Then
            Exit For
        Else
            Range(address).Characters(Start:=lngStart, Length:=Len(Search)).Font.ColorIndex = 7
        End If
    Next
    
    
    Exit Sub
MarkText_Err:
    If Err <> 0 Then
        Debug.Print "MarkText", Err.Number, Err.Description
    End If
End Sub


 


本站文章旨在为该问题提供解决思路及关键性代码,并不能完成应该由网友自己完成的所有工作,请网友在仔细看文章并理解思路的基础上举一反三、灵活运用。

access911.net 原创文章,作者本人对文章保留一切权利。
如需转载必须征得作者同意并注明本站链接

 

 
相关文章
     没有手动相关文章
     搜索整个数据库,查找一段文字字符串
     如何实现windows的搜索功能(查找指定文件/文件夹)?(二)
     如何实现windows的搜索功能(查找指定文件/文件夹)?(一)
 
评论
     查看或发表更多的评论,请单击这里。
 
 
 
 
 
   
  Access911.net   |   a9BBS   |   OTaA System   |
建站日期:2000年4月2日  |  设计施工:陈格 ( access911 & cg1 )
 Copyright © 2000 - 2003 COMET, 陈格 保留所有权利