将链接到关键字的多个单元格从一列复制到一个单元格中

Question

我正在尝试将链接到多个工作表中的关键字的单元格值复制到概览工作表中的一个单元格中。如果关键字仅在工作表上出现一次，则代码有效，但如果关键字出现多次，则只会复制并粘贴关键字首先出现的行中的单元格值。

我的前任创建的代码。

Public Sub refresh_previous_occupation()
Dim WSUE As Worksheet
Dim ws As Worksheet
Dim rng As Range
Dim str As String
Dim i As Integer
Dim n As Integer
Dim finalrow As Integer
Dim finalrow_ue As Integer
Dim wsarr(6) As Variant

'Array with worksheets that shouldn't be searched
wsarr(0) = Tabelle1.Name
wsarr(1) = Tabelle2.Name
wsarr(2) = Tabelle3.Name
wsarr(3) = Tabelle15.Name
wsarr(4) = Tabelle17.Name
wsarr(5) = Tabelle16.Name
wsarr(6) = Tabelle19.Name

Set WSUE = ThisWorkbook.Worksheets("Übersicht")
finalrow_ue = WSUE.Cells(Rows.Count, 1).End(xlUp).Row

'Search for all keywords in the overview worksheet
For i = 7 To finalrow_ue
    str = "" 'reset string variable
    For n = 1 To ThisWorkbook.Worksheets.Count 'look through all worksheets
        Set ws = ThisWorkbook.Worksheets(n)
        If isinarray(ws.Name, wsarr) = False And ws.Visible = xlSheetVisible Then 'check if worksheet is in the array with worksheets that shouldn't be searched an if the worksheet is visible
            Set rng = ws.Range("A7:A100").Find(what:=WSUE.Cells(i, 1), LookIn:=xlValues) 'Search for the current keyword on worksheet
            If Not rng Is Nothing Then
                If str = "" Then 'check if string variable is filled already
                    If Not rng.Offset(0, 1) = "" Then
                        str = rng.Offset(0, 1).value & " (" & ws.Name & ")" 'add cell value to string variable
                    End If
                Else
                    If Not rng.Offset(0, 1) = "" Then
                        str = str & "; " & vbCrLf & rng.Offset(0, 1).value & " (" & ws.Name & ")" 'add cell value to string variable
                    End If
                End If
            End If
        End If
    Next n
    
    WSUE.Cells(i, 2) = str 'Add string variable value to overview

Next i

End Sub

是否可以添加一个循环来再次搜索工作表以查找关键字的每个实例，还是我必须找到一种新方法来解决我的问题？

Answer 1

您的搜索范围相对较小，因此对单元格进行简单循环应该没问题 - 不需要Find()：

Public Sub refresh_previous_occupation()
    Dim WSUE As Worksheet
    Dim ws As Worksheet
    Dim str As String
    Dim i As Integer
    Dim finalrow As Integer
    Dim finalrow_ue As Integer
    Dim wsarr As Variant, f, s, c As Range
    
    'Array with worksheets that shouldn't be searched
    wsarr = Array(Tabelle1.Name, Tabelle2.Name, Tabelle15.Name, _
                  Tabelle16.Name, Tabelle19.Name)

    Set WSUE = ThisWorkbook.Worksheets("Übersicht")
    finalrow_ue = WSUE.Cells(Rows.Count, 1).End(xlUp).Row

    'Search for all keywords in the overview worksheet
    For i = 7 To finalrow_ue
        f = WSUE.Cells(i, 1)   'looking for this
        str = ""               'reset string variable
        For Each ws In ThisWorkbook.Worksheets
            'check sheet not in list to ignore
            If IsError(Application.Match(ws.Name, wsarr, 0)) Then
                'search range is small, so a simple loop is fine here...
                For Each c In ws.Range("A7:A100").Cells
                    If c.Value = f Then
                        s = c.Offset(0, 1).Value
                        If Len(s) > 0 Then
                            If Len(str) > 0 Then str = str & vbLf 'add new line if needed
                            str = str & s & " (" & ws.Name & "," & c.Address(0, 0) & ")"
                        End If
                    End If
                Next c
            End If
        Next ws
        WSUE.Cells(i, 2) = str 'Add string variable value to overview
    Next i
End Sub