Excel VBA查找范围内的单词并复制以同一单词开头的所有单元格

我的日常工作需要帮助。我有一行（2），其中有许多填充的单元格。在一个例子中，我有一对连续的单元格（数字不时变化），以单词Blue开头（以数字1、2、3、4等结尾）。忽略数字，我想复制所有单元格（作为一个范围？），从单词Blue*开始。我已成功使用以下代码找到并复制了一个单元格：

Sub findcopy()
  Dim rFound As Range
  
  Set rFound = Sheets("page 1").Rows(2).Find(What:="Blue", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

If Not rFound Is Nothing Then rFound.Offset(0, 0).Resize(1).Copy Destination:=Sheets("page 1").Range("AG2")

End Sub

---

谢谢

我想这应该可以完成任务。我将尝试进一步完善它，但目前它正在发挥作用。尽管如此，在我接受自己的建议之前，我还是会欢迎其他答案（如果更好的话也会接受）和建议。谢谢

Sub SearchX()
Dim c, destination As Range, i As Long
Const SEARCH_TERM As String = "Blue"
Set destination = ActiveSheet.Range("AA10")
For Each c In ActiveSheet.Range("B2:BB2")
i = 1
Do While InStr(i, c.Value, SEARCH_TERM) > 0
destination.Value = c.Value
Set destination = destination.Offset(1, 0)
i = InStr(i, c.Value, SEARCH_TERM) + Len(SEARCH_TERM)
Loop
Next
End Sub

---

另一种更快的方法是

• 将范围读入vba数组
• 通过将相关数据收集到为此而设计的对象中来处理数组
• 创建相关数据的输出数组并将其写回工作表

上述操作速度更快，因为您只需访问工作表两次；而工作表访问是VBA中速度较慢的一部分。速度增加可以达到一个数量级

在下面的代码中，我选择使用ArrayList作为集合对象。但是你可以用其他的东西

Option Explicit
Option Compare Text

Sub findAndCopy()
    Dim vSrc As Variant, rRes As Range, V As Variant
    Dim wsSrc As Worksheet
    Dim AL As Object
    
Set wsSrc = Worksheets("Sheet2")
With wsSrc
    'read data into array
    vSrc = .Range(.Cells(2, 1), .Cells(2, .Columns.Count).End(xlToLeft))
    
    'set the output range Cell 1
    Set rRes = wsSrc.Cells(10, 1)
End With

Set AL = CreateObject("System.Collections.ArrayList")

'collect the relevant data
For Each V In vSrc
    If V Like "Blue*" Then _
        AL.Add V
Next V

'resize the output range
Set rRes = rRes.Resize(rowsize:=1, columnsize:=AL.Count)

'write results to output range and format
With rRes
    .EntireRow.Clear
    .Value = AL.toarray
    .Style = "Output" 'optional and will vary depending on language
    .EntireColumn.AutoFit
End With
     
End Sub

除了MS文档之外，我还发现它有助于理解数组列表及其使用

---

为此，编码似乎比使用字典或集合对象更简单。

谢谢Ron，今晚我将测试它。谢谢你的时间。