Excel VBA 多表搜索使用一列中的數據

Question

我正在嘗試從我的 excel 工作簿中的多個工作表中搜索列中列出的值。 如果 excel 找到匹配項，我希望它返回具有該值的選項卡的工作表名稱。

這是我到目前為止所做的。 我決定首先使用一個關鍵字搜索多個選項卡，復制並粘貼工作表名稱。 下面的代碼僅在其他工作表包含相同關鍵字時粘貼第一個結果工作表名稱。 我想知道如何提取包含相同關鍵字的其他工作表名稱。

我還想知道如何設置關鍵字以使用字段列表 A 列中的信息。

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

以下代碼應該適用於您所描述的內容。

幾個反饋項目：

1. 標記循環和 if 語句顯着提高了代碼可讀性
2. 永遠不要重用變量名（即lastrow ），這會使其難以閱讀並可能導致以后難以發現的問題
3. 使用循環變量（即Next i ）跟蹤所有Next ，這提高了可讀性並幫助您跟蹤循環的結束
4. .Activate和.Select在 vba 中通常是不需要的，最好在你引用的內容中明確

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

請試試這個變體（不要擔心代碼太長——程序員思考的時間越長，寫的越多，程序運行得越好......通常是這樣）：

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

您可以在這個演示工作簿中看到它是如何工作的 - 創建到 Keywords.xlsm 的鏈接

編輯順便說一句，此代碼的第二部分FindAll() 函數是Chip Pearson宏的略微縮短版本。 自己保留這個鏈接，有很多有用的東西可以幫助你在未來的發展。