Trying to copy multiple cells linked to a keyword from one column into one cell-CodePudding

I am trying to copy cell values linked to keywords from multiple worksheets into one cell in an overview worksheet. Currently the code works perfectly fine if the keyword only appears once on a worksheet, but if the keyword appears multiple times it only copy and pastes the cell value in the row where the key word appears first.

This ist the code I am currently working with, it's been created by my predecessor.

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

I'm not sure if there is a possibility for me to add a loop to search through the worksheets again to find every instance of the keyword with this code or if I am going to have to find a new way to solve my problem.

I'm brand new to coding and still learning a lot every day, so hopefully I've checked thorougly enough if this question has been answered before. Please let me know if I've not been clear with what I'm trying to do or what my problem is.

CodePudding user response：

Your search range is relatively small, so a simple loop over the cells should be fine - no real need for 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