按关键词跨工作簿查找

现有多个Excel工作簿，含有同名工作表，且字段信息一致。我们要如何根据【工作表名】、【字段】以及【关键词】，在多个Excel工作簿内查找匹配的数据呢？

功能介绍

1.输入[查找工作表]、下拉选择[查找字段]，并输入[查找值]；

2.点击“查找”按钮，选择文件夹路径，就可以将多个Excel的相关匹配数据读取进来了；

3.点击“清除”按钮，即可将读取的全部数据删除。

VBA代码

1.查找

Function GetSelectedPath()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "请选择要查找的工作簿路径"
        If .Show Then
            GetSelectedPath = .SelectedItems(1)
        End If
    End With
End Function

Sub 根据关键字跨工作簿查找记录()
    Dim selectedPath As String
    selectedPath = GetSelectedPath()
    If selectedPath = "" Then
        Exit Sub
    End If

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '查找的关键词
    Dim kw As String
    kw = Range("H1").Value

    Dim sht As Worksheet
    Set sht = ActiveSheet

    Dim fn As String
    fn = Dir(selectedPath & "\*.xls*")

    '获取工作表数据的查找列号
    Dim fieldColumn As Integer
    '选中第四行数据
    Range(Range("a4"), Range("a4").End(xlToRight)).Select
    fieldColumn = Selection.Find(What:=Range("E1").Value, LookAt:=xlWhole).Column
    Dim wb As Workbook, findInSht As Worksheet
    Dim rn As Integer
    rn = 5
    Do While fn <> ""
        Set wb = Workbooks.Open(selectedPath & "\" & fn, 0)
        '在哪个工作表查找
        Set findInSht = wb.Sheets(sht.Range("B1").Value)
        Dim i As Integer
        '查找匹配的数据
        wb.Close SaveChanges:=False
        fn = Dir
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

2.清除

Sub 清除查找内容()
    Dim sht As Worksheet
    Set sht = ActiveSheet
    Dim lastRow As Integer
    lastRow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row
    If lastRow >= 5 Then
        sht.Range("5:" & lastRow).Delete Shift:=xlUp
    End If
End Sub