VBA在多个文件中Find某字符的数据并复制出来

VBA在多个文件中Find某字符的数据并复制出来

今天在工作中碰到的问题

【问题】有几个文件，每个文件中有很多条记录，我现在要提取出含有“名师”两个字符的记录。

文件如下：

【常规做法】打开文件--查找---复制---粘贴---关闭文件，再来一次，再来一次

晕，如果文件不多，数据不多那还好，如果文件多，每个文件的记录也很多，那就是“加班加班啦”

【解决】先Application.GetOpenFilename要打开文件对话框，选中要打开的文件，存入数组，再GetObject(路径)每一个文件打开，用Find指定字符，找到第一个时用firstAddress记录起来，再FindNext查找下一个，当循环到最初的位置时停止，把找到的数据整行复制出来就可也。完成一个文件，再找开一个文件……

【VBA代码】

代码语言：javascript复制

SubGetFile_Find_FindNext()
    Dim fileToOpen, x, total_file_path, m,title_row
    Dim MyOb As Object, mysht As Worksheet
    fileToOpen =Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , "打开文件", , True)
    If TypeName(fileToOpen) ="Boolean" Then MsgBox "你选择了“取消”,将要退出程序":Exit Sub
    Application.DisplayAlerts = False
'    Application.ScreenUpdating = False
    Setmysht = ActiveSheet
'    mysht.UsedRange.Clear
    title_row = 1
    m = 0
    i = 0
    ss = VBA.InputBox("输入要查找的字符")
    If ss = "" Then MsgBox "你没有输入": Exit Sub
    For Each rr In fileToOpen
        Set MyObj = GetObject(rr)
        With MyObj
            With MyObj.Worksheets(1)
                Set c = .Cells.Find(ss,Lookat:=xlPart, LookIn:=xlValues)
                If Not c Is Nothing Then
                    firstAddress = c.Address
                    Do
                         i = i   1
                        Lrow =mysht.Cells(Rows.Count, 1).End(xlUp).Row   1
                        c.EntireRow.Copymysht.Cells(Lrow, 1)
                        Set c =.Cells.FindNext(c)
                    Loop While Not c Is NothingAnd c.Address <> firstAddress
                End If
                m = m   1
            End With
            .Close False
        End With
        Set MyObj = Nothing
    Next
    Application.DisplayAlerts = True
'    Application.ScreenUpdating = True
    MsgBox "打开文件数：" & m & vbCrLf & "找到记录数：" & i
End Sub

【运行】

A.打开文件对话框，找到你要打开的文件

B.弹出输入字符的对话框，输入你要查找的字符

C.完成，打开文件数：3个，查找到了记录：36

vba

0 人点赞