0

我正在尝试从我的 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
4

2 回答 2

0

以下代码应该适用于您所描述的内容。

几个反馈项目：

  1. 标记循环和 if 语句显着提高了代码的可读性
  2. 永远不要重用变量名（即lastrow），它会让人难以阅读，并且可能会导致以后难以发现的问题
  3. 跟随所有Next循环变量（即Next i），这提高了可读性并帮助您跟踪循环的结束
  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
于 2020-09-24T04:10:23.297 回答
0

请尝试这个变体（不要担心代码这么长——程序员想的越长，写的越多，程序就越好……通常是这样）：

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

您可以在这个演示工作簿中看到它是如何工作的 - Create Links To Keywords.xlsm

编辑顺便说一句，这段代码的第二部分FindAll() 函数是Chip Pearson宏的略微缩短的版本。为自己保留这个链接，有很多有用的东西可以帮助你在未来的发展。

于 2020-09-24T14:02:19.173 回答