Excel VBA Multiple Sheet Search using Data from one Column

Question

I am trying to search for values listed in a column from multiple sheets in my excel workbook. If excel finds a match I would like it to return sheet names of the tabs that had the value.

Here is what i have done so far. I decided to start off by using one keyword to search multiple tabs, copy and paste the sheet name. The code below only paste the first resulting sheet name when there are other sheets containing the same keyword. I would like to know how i can pull the other sheet names that contain the same keyword.

I would also like to know how i can set up the keyword to use information in Column A of the Field List.

Sub FinalAppendVar()
 Dim ws As Worksheet
 Dim arr() As String
 Keyword = "adj_veh_smart_tech_disc"
 Totalsheets = Worksheets.Count

 For i = 1 To Totalsheets
  If Worksheets(i).Name <> "Main" Or InStr(1, Worksheets(i).Name, " Checks") Or Worksheets(i).Name 
   <>_ "Field Lists" Then
   lastrow = Worksheets(i).Cells(Rows.Count, 4).End(xlUp).Row
  For j = 2 To lastrow
     If Worksheets(i).Cells(1, 3).Value = Keyword Then
       Worksheets("Field Lists").Activate
       lastrow = Worksheets("Field Lists").Cells(Rows.Count, 4).End(xlUp).Row
       Worksheets("Field Lists").Cells(lastrow + 1, 5).Value = Worksheets(i).Name
       Worksheets("Field Lists").Cells(lastrow + 2, 5).Value = Worksheets(i).Name
     End If

     Next

   End If
  Next
End Sub 

Answer 1

The following code should work for what you described.

A couple feedback items:

1. Tabbing out loops and if statements significantly improves code readability
2. Never reuse variable names (i.e. lastrow), it makes it hard to read and can cause issues that are difficult to find later on
3. Follow all Next with the loop variable (i.e. Next i), this improves readability and helps you keep track of the ends of loops
4. .Activate and .Select are generally never required in vba, its better to be explicit in what you are referencing

Sub FinalAppendVar()
    Dim searchSheet As Excel.Worksheet
    Dim pasteSheet As Excel.Worksheet
    Dim keyword As String
    Dim lastSearchRow As Integer
    Dim lastPasteRow As Integer
    
    ' set the worksheet to paste to
    Set pasteSheet = ThisWorkbook.Worksheets("Field Lists")
    
    ' set keyword to look for
    keyword = "adj_veh_smart_tech_disc" '<-- manual entry
    'keyword = pasteSheet.Range("A1").Value '<-- use value in cell A1 on the defined pasteSheet
    
    ' loop through all sheets in the workbook
    For i = 1 To ThisWorkbook.Worksheets.Count
        ' set the current worksheet we are looking at
        Set searchSheet = ThisWorkbook.Worksheets(i)
        ' check if the current sheet is one we want to search in
        If searchSheet.Name <> "Main" Or InStr(1, searchSheet.Name, " Checks") Or searchSheet.Name <> "Field Lists" Then
            ' current worksheet is one we want to search in
            
            ' find the last row of data in column D of the current sheet
            lastSearchRow = searchSheet.Cells(1048576, 4).End(xlUp).Row
            
            ' loop through all rows of the current sheet, looking for the keyword
            For j = 2 To lastSearchRow
                If searchSheet.Cells(j, 3).Value = keyword Then
                    ' found the keyword in row j of column C in the current sheet
                    
                    ' find the last row of column D in the paste sheet
                    'lastPasteRow = pasteSheet.Cells(1048576, 4).End(xlUp).Row
                    lastPasteRow = pasteSheet.Cells(1048576, 5).End(xlUp).Row '<-- update based on OPs comment
                    ' paste the name of the current search sheet to the last empty cell in column E
                    pasteSheet.Cells(lastPasteRow + 1, 5).Value = searchSheet.Name
                    ' not sure if the next line is needed, looks like it pastes again immediately below the previous
                    pasteSheet.Cells(lastPasteRow + 2, 5).Value = searchSheet.Name
                    
                    ' to save time consider exiting the search in the current sheet since the keyword was just found
                    ' this will move to the next sheet immediately and not loop through the rest of the rows on the current
                    ' search sheet.  This may not align with the usecase so it is currently commented out.
                    
                    'Exit For '<--uncomment this to move to the next sheet after finding the first instance of the keyword
                Else
                    ' the keyoword was not in row j of column C
                    ' do nothing
                End If
            Next j
        Else
            ' current sheet is one we don't want to search in
            ' do nothing
        End If
    Next i
End Sub

Answer 2

Please try this variant (Don't worry that the code is so long - the longer the programmer thought and the more wrote, the better the program works ... usually it is):

Option Explicit

Sub collectLinks()
Const LIST_SHEET_NAME As String = "Field Lists"
Dim wsTarget As Worksheet
Dim wsEach As Worksheet
Dim keywordCell As Range
Dim sKeyword As String
Dim linkCell As Range
Dim aFound As Range
Dim aCell As Range
    On Error Resume Next
    Set wsTarget = ActiveWorkbook.Worksheets(LIST_SHEET_NAME)
    On Error GoTo 0
    If wsTarget Is Nothing Then
        MsgBox "'" & LIST_SHEET_NAME & "' not exists in active workbook", vbCritical, "Wrong book or sheet name"
        Exit Sub
    End If
Rem Clear all previous results (from column B to end of data)
    wsTarget.UsedRange.Offset(0, 1).ClearContents
Rem Repeat for each cell of column A in UsedRange:
    For Each keywordCell In Application.Intersect(wsTarget.UsedRange, wsTarget.Columns("A")) ' It can be changed to "D", "AZ" or any other column
        sKeyword = keywordCell.Text
        If Trim(sKeyword) <> vbNullString Then
            Application.StatusBar = "Processed '" & sKeyword & "'"
            Set linkCell = keywordCell
            For Each wsEach In ActiveWorkbook.Worksheets
                If wsEach.Name <> LIST_SHEET_NAME Then
                    Application.StatusBar = "Processed '" & sKeyword & "' Search in '" & wsEach.Name & "'"
                    Set aFound = FindAll(wsEach.UsedRange, sKeyword)
                    If Not aFound Is Nothing Then
                        For Each aCell In aFound
                            Set linkCell = linkCell.Offset(0, 1) ' Shift to rught, to the next column
                            linkCell.Formula2 = "=HYPERLINK(""#" & aCell.Address(False, False, xlA1, True) & """,""" & _
                                aCell.Worksheet.Name & " in cell " & aCell.Address(False, False, xlA1, False) & """)"
                        Next aCell
                    End If
                End If
            Next wsEach
        End If
    Next keywordCell
    Application.StatusBar = False
Rem Column width
    wsTarget.UsedRange.Columns.AutoFit
End Sub

Function FindAll(SearchRange As Range, FindWhat As Variant) As Range
Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
    For Each Area In SearchRange.Areas
        With Area
            If .Cells(.Cells.Count).Row > MaxRow Then
                MaxRow = .Cells(.Cells.Count).Row
            End If
            If .Cells(.Cells.Count).Column > MaxCol Then
                MaxCol = .Cells(.Cells.Count).Column
            End If
        End With
    Next Area
    Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
Rem If your keyword can be a part of cell then change parameter xlWhole to xlPart:
    Set FoundCell = SearchRange.Find(FindWhat, LastCell, xlValues, xlWhole, xlByRows)
    If Not FoundCell Is Nothing Then
        Set FirstFound = FoundCell
        Do Until False ' Loop forever. We'll "Exit Do" when necessary.
            If ResultRange Is Nothing Then
                Set ResultRange = FoundCell
            Else
                Set ResultRange = Application.Union(ResultRange, FoundCell)
            End If
            Set FoundCell = SearchRange.FindNext(after:=FoundCell)
            If (FoundCell Is Nothing) Then
                Exit Do
            End If
            If (FoundCell.Address = FirstFound.Address) Then
                Exit Do
            End If
        Loop
    End If
        
    Set FindAll = ResultRange
End Function

You can see how it works in this demo workbook - Create Links To Keywords.xlsm

EDIT By the way, the second part of this code, the FindAll() function, is a slightly shortened version of the Chip Pearson macro. Keep this link for yourself, there are many useful things to help you in future development.