將鏈接到關鍵字的多個單元格從一列復制到一個單元格中

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