如何修改VBA代码实现筛选后TextJoin结果并粘贴至单个单元格

你原来的代码频繁使用Select/Activate切换工作表，这是导致卡顿的核心原因——这类操作会触发Excel界面重绘，处理大量数据时尤其明显。下面直接用VBA完成筛选、合并并输出到单个单元格，全程避免不必要的工作表切换和复制粘贴：

方案1：兼容所有Excel版本（使用VBA原生Join函数） #

Sub FilterAndJoin()
    Dim wsSearch As Worksheet, wsWords As Worksheet
    Dim lastChar As String
    Dim dataRange As Range, cell As Range
    Dim resultArr As Variant
    Dim i As Integer
    
    ' 直接绑定工作表对象，避免切换/选择操作
    Set wsSearch = ThisWorkbook.Worksheets("Searching")
    Set wsWords = ThisWorkbook.Worksheets("WordsList")
    
    ' 获取要筛选的末尾字符
    lastChar = wsSearch.Range("A2").Value
    If lastChar = "" Then Exit Sub ' 空值直接退出
    
    ' 获取WordsList中A列的有效数据范围（假设表头在A1）
    Set dataRange = wsWords.Range("A2:A" & wsWords.Cells(wsWords.Rows.Count, "A").End(xlUp).Row)
    
    ' 初始化数组存储匹配项
    ReDim resultArr(1 To dataRange.Cells.Count)
    i = 0
    
    ' 遍历数据，筛选末尾字符匹配的项
    For Each cell In dataRange
        If Right(cell.Value, Len(lastChar)) = lastChar Then
            i = i + 1
            resultArr(i) = cell.Value
        End If
    Next cell
    
    ' 调整数组大小到实际匹配数量
    If i > 0 Then
        ReDim Preserve resultArr(1 To i)
        ' 合并数组内容并写入目标单元格（这里用S1，和你原来的目标一致）
        wsSearch.Range("S1").Value = Join(resultArr, ", ") ' 分隔符可自定义，比如换行用vbNewLine
    Else
        wsSearch.Range("S1").Value = "" ' 无匹配项时清空单元格
    End If
    
    ' 清理对象
    Set wsSearch = Nothing
    Set wsWords = Nothing
    Set dataRange = Nothing
End Sub

方案2：Excel 2019及以上版本（直接用TextJoin函数，更简洁） #

如果你的Excel版本支持TextJoin（2019及以后，或365订阅版），可以用更高效的方式，不需要循环：

Sub FilterAndJoinWithTextJoin()
    Dim wsSearch As Worksheet, wsWords As Worksheet
    Dim lastChar As String
    Dim dataRange As Range
    
    Set wsSearch = ThisWorkbook.Worksheets("Searching")
    Set wsWords = ThisWorkbook.Worksheets("WordsList")
    
    lastChar = wsSearch.Range("A2").Value
    If lastChar = "" Then
        wsSearch.Range("S1").Value = ""
        Exit Sub
    End If
    
    Set dataRange = wsWords.Range("A2:A" & wsWords.Cells(wsWords.Rows.Count, "A").End(xlUp).Row)
    
    ' 用WorksheetFunction.TextJoin直接合并符合条件的单元格
    On Error Resume Next ' 捕获无匹配项的错误
    wsSearch.Range("S1").Value = WorksheetFunction.TextJoin(", ", True, _
        wsWords.Evaluate("IF(RIGHT(A2:A" & dataRange.Row + dataRange.Rows.Count - 1 & ", " & Len(lastChar) & ")=""" & lastChar & """, A2:A" & dataRange.Row + dataRange.Rows.Count - 1 & ", """")"))
    On Error GoTo 0
    
    Set wsSearch = Nothing
    Set wsWords = Nothing
    Set dataRange = Nothing
End Sub

关键优化点 #

• 全程不使用Select/Activate，直接操作工作表和单元格对象，彻底避免切换工作表的卡顿
• 用数组或TextJoin批量处理数据，比逐行复制粘贴效率高得多
• 自动识别数据区域的最后一行，不需要硬编码12169这种固定行数，适配数据变化

内容的提问来源于stack exchange，提问作者Dhaidan