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