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

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

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

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

excel

vba