VBA在一个区域中查找一个单词，并复制以同一单词开头的所有单元格

Question

我的日常工作需要帮助。我有一行(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

感谢

Answer 1

我想这应该能完成任务。我会尝试进一步完善它，但目前这是有效的。不过，在我接受自己的答案之前，我会欢迎其他答案(如果更好的话，我会接受(和建议。感谢

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

Answer 2

另一种更快的方法是

• 将范围读取到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文档之外，我还发现这篇文章有助于理解数组列表及其使用。

为此，编码似乎比使用Dictionary或Collection对象更简单。