Suchen - auch in mehrere Dateien

Frage: Ein Suchbegriff soll in allen Tabellenblättern gesucht werden. Die ganze Zeile der Fundstelle soll in ein neues Tabellenblatt kopiert werden. Wie geht das?

Option Explicit
Public Sub Main()
    Dim intLastColumn As Integer
    Dim wksSheetNew As Worksheet
    Dim wksSheet As Worksheet
    Dim lngLastRow As Long
    Dim strFound As String
    Dim rngRange As Range
    Dim strLink As String
    Dim strTMP As String
    On Error GoTo Fin
    Application.DisplayAlerts = False
    For Each wksSheet In ThisWorkbook.Worksheets
        If wksSheet.Name Like "Found_*" Then
            wksSheet.Delete
        End If
    Next wksSheet
    'strFound = "Laptops"
    strFound = InputBox("Enter search term!", "Search", "Laptops")
    If Trim(strFound) = "" Then Exit Sub
    Set wksSheetNew = Worksheets.Add(Before:=Sheets(1))
    wksSheetNew.Name = "Found_" & Format(Now, "dd_mm_yy_hh_mm_ss")
    lngLastRow = 1
    For Each wksSheet In ThisWorkbook.Worksheets
        If wksSheet.Name <> wksSheetNew.Name Then
            Set rngRange = wksSheet.Columns(2).Find(What:=strFound, _
                LookIn:=xlValues, LookAt:=xlPart)
            If rngRange Is Nothing Then
            Else
                strLink = rngRange.Value
            End If
            If Not rngRange Is Nothing Then
                strTMP = rngRange.Address
                Do
                    lngLastRow = lngLastRow + 1
                    wksSheet.Cells(rngRange.Row, rngRange.Column).EntireRow.Copy _
                        Destination:=wksSheetNew.Cells(lngLastRow, 1)
                    intLastColumn = Cells(lngLastRow, _
                        Columns.Count).End(xlToLeft).Column + 1
                    Cells(lngLastRow, intLastColumn).Value = "Sheet"
                    wksSheetNew.Hyperlinks.Add Anchor:=wksSheetNew.Cells _
                        (lngLastRow, intLastColumn), Address:="", _
                        SubAddress:=wksSheet.Name & "!" & rngRange.Address, _
                        TextToDisplay:="Found in Sheet " _
                        & wksSheet.Name & " " & rngRange.Address
                    Set rngRange = wksSheet.Columns(2).FindNext(rngRange)
                Loop While rngRange.Address <> strTMP
                wksSheetNew.Cells.EntireColumn.AutoFit
            End If
        End If
    Next wksSheet
Fin:
    Application.DisplayAlerts = True
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
    If strTMP = "" Then
        For Each wksSheet In ThisWorkbook.Worksheets
            If wksSheet.Name Like "Found_*" Then
                wksSheet.Delete
            End If
        Next wksSheet
        MsgBox "Search term was not found!"
    Else
        MsgBox "All matching data has been copied."
    End If
    Set rngRange = Nothing
    Set wksSheetNew = Nothing
End Sub

Hier noch eine Beispieldatei: Sample

Frage: Kann ich das auch auf mehrere Datein anwenden? Diese sollen über einen Dialog ausgewählt werden? "With multiselect - hold down ctrl key while clicking on the Excel files..."

Option Explicit
Public Sub Main_1()
    Dim intLastColumn As Integer
    Dim wksSheetNew As Worksheet
    Dim wksSheet As Worksheet
    Dim intFiles As Integer
    Dim varFiles As Variant
    Dim lngLastRow As Long
    Dim strFound As String
    Dim rngRange As Range
    Dim strLink As String
    Dim wkbBook As Object
    Dim strTMP As String
    On Error GoTo Fin
    varFiles = Application.GetOpenFilename( _
        FileFilter:="Excel files (*.xls*), *.xls*", _
        MultiSelect:=True)
    If VarType(varFiles) = vbBoolean Then Exit Sub
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    For Each wksSheet In ThisWorkbook.Worksheets
        If wksSheet.Name Like "Found_*" Then
            wksSheet.Delete
        End If
    Next wksSheet
    'strFound = "Laptops"
    strFound = InputBox("Enter search term!", "Search", "Laptops")
    If Trim(strFound) = "" Then Exit Sub
    Set wksSheetNew = ThisWorkbook.Worksheets.Add(Before:=ThisWorkbook.Worksheets(1))
    wksSheetNew.Name = "Found_" & Format(Now, "dd_mm_yy_hh_mm_ss")
    lngLastRow = 1
    For intFiles = 1 To UBound(varFiles)
        Set wkbBook = Workbooks.Open(varFiles(intFiles))
        For Each wksSheet In wkbBook.Worksheets
            If wksSheet.Name <> wksSheetNew.Name Then
                Set rngRange = wksSheet.Columns(2).Find(What:=strFound, _
                    LookIn:=xlValues, LookAt:=xlPart)
                If rngRange Is Nothing Then
                Else
                    strLink = rngRange.Value
                End If
                If Not rngRange Is Nothing Then
                    strTMP = rngRange.Address
                    Do
                        lngLastRow = lngLastRow + 1
                        wksSheet.Cells(rngRange.Row, rngRange.Column).EntireRow.Copy _
                            Destination:=wksSheetNew.Cells(lngLastRow, 1)
                        intLastColumn = Cells(lngLastRow, _
                            Columns.Count).End(xlToLeft).Column + 1
                        Cells(lngLastRow, intLastColumn).Value = "Sheet"
                        wksSheetNew.Hyperlinks.Add Anchor:=wksSheetNew.Cells _
                            (lngLastRow, intLastColumn), Address:="", _
                            SubAddress:=wksSheet.Name & "!" & rngRange.Address, _
                            TextToDisplay:=wksSheet.Name
                        Set rngRange = wksSheet.Columns(2).FindNext(rngRange)
                    Loop While rngRange.Address <> strTMP
                    wksSheetNew.Cells.EntireColumn.AutoFit
                End If
            End If
        Next wksSheet
        wkbBook.Close False
        Set wkbBook = Nothing
    Next intFiles
Fin:
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
    If strTMP = "" Then
        For Each wksSheet In ThisWorkbook.Worksheets
            If wksSheet.Name Like "Found_*" Then
                wksSheet.Delete
            End If
        Next wksSheet
        MsgBox "Search term was not found!"
    Else
        MsgBox "All matching data has been copied."
    End If
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    Set wkbBook = Nothing
    Set rngRange = Nothing
    Set wksSheetNew = Nothing
End Sub

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...