Excel 复制并粘贴所有符合条件的单元格

我是VBA和宏的初学者；因此，我不确定确切的措辞是什么，但我相信我正在寻找有关循环的帮助

我的宏当前部分匹配“SheetJS”中包含“Mercedes Benz”或“BMW”的每一行中的单元格，并将值粘贴到“Sheet1”中的D列。但是，它只复制部分匹配文本的第一个迭代/单元格

我希望宏复制并通过所有匹配项。例如，应将第一次迭代复制/粘贴到“Sheet1”D列、H列第二次、L列第三次，依此类推。每个迭代之间应该有3个单元格

我甚至不知道如何推进这项工作

任何提示都将不胜感激

谢谢

Sub Extract_Data_or()
    For Each cell In Sheets("SheetJS").Range("A1:ZZ200")
        matchrow = cell.Row

        If (cell.Value Like "*Mercedez-Benz*") Or (cell.Value Like "*BMW*") Then
            Sheets("Sheet1").Range("D" & matchrow).Value = cell.Value
        End If
    Next
End Sub

编辑01.09.20

我希望宏获取每行中的所有迭代/部分匹配并复制它们。当前宏仅复制第一个匹配项。我不想复制整行，只复制单个单元格

例如，“SheetJS”中的第一个匹配项应复制到“Sheet1”中的D列。第二个匹配项（如有）应复制到H列、L列第3个、P列第4个等。每个匹配项应彼此相隔4个单元格

所有匹配项都以黄色突出显示。每个单元格中的值应复制到“Sheet1”中

---

每行的第一个匹配项在D列，第二个匹配项（如果有的话）在H列，等等。

你昨天问过类似的问题。我要求澄清，我提供了一个解决方案，但没有收到您的任何迹象。。。 无论如何，也许这次你会看看下一段代码，也许会对它进行测试。它工作得非常快，避免了单元迭代。它只在内存中工作：

Private Sub Extract_Data_Bis()
  Dim rngArr As Variant, dArr As Variant
  Dim sh As Worksheet, i As Long, j As Long, k As Long
  Dim lngOcc As Long, lngChanges As Long, boolFound As Boolean
  Dim lngSameRow As Long, lngMised As Long

  Set sh = Sheets("Sheet1")
   rngArr = Sheets("SheetJS").Range("A1:ZZ200").Value
   dArr = sh.Range("D1:F200").Value

    For i = 1 To UBound(rngArr, 1)
        boolFound = False: k = 0: lngSameRow = 0
        For j = 1 To UBound(rngArr, 2)
          If InStr(UCase(rngArr(i, j)), UCase("Mercedez-Benz")) > 0 Or _
                              InStr(UCase(rngArr(i, j)), "BMW") > 0 Then
              If Not boolFound Then
                lngSameRow = i
                k = 1
              Else
                If lngSameRow = i Then
                    k = k + 1
                End If
              End If
              lngOcc = lngOcc + 1: boolFound = True
              If k <= 3 Then
                dArr(i, k) = rngArr(i, j)
                lngChanges = lngChanges + 1
              Else
                lngMised = lngMised + 1
              End If

          End If
       Next j
    Next i
    sh.Range("D1:F200").Value = dArr
    MsgBox lngOcc & " occurrences, versus " & lngChanges & " changes done. " & lngMised & " missed..."
End Sub

Private Sub-Extract_Data_Bis（）
Dim rngArr作为变型，dArr作为变型
将sh设置为工作表，i设置为长，j设置为长，k设置为长
Dim lngOcc为Long，lngChanges为Long，boolFound为Boolean
变暗变长，变暗变长
设置sh=图纸（“图纸1”）
rngArr=板材（“SheetJS”）.范围（“A1:ZZ200”）.值
dArr=sh.范围（“D1:F200”）.值
对于i=1至uBond（rngArr，1）
boolFound=False:k=0:lngSameRow=0
对于j=1至UBound（rngArr，2）
如果仪表（UCase（rngArr（i，j）），UCase（“Mercedez Benz”））>0或_
仪表（UCase（rngArr（i，j）），“BMW”）>0
如果不是土狗的话
lngSameRow=i
k=1
其他的
如果lngSameRow=i，则
k=k+1
如果结束
如果结束
lngOcc=lngOcc+1:boolFound=True
如果k
matchrow=cell.Row
=>
matchrow=cell.Row
@AntiDrondert No.它必须是一个数字<代码>范围（“D”和匹配行）

匹配行

-据我所知，必须是独立的计数器。如果你想对每一列进行迭代，我想它必须是这样的：

for i=1 to lastcolumncount for Sheets（“SheetJS”）.Range（Sheets（“SheetJS”）.cell（1，i），Sheets（“SheetJS”）.cell（200，i）“你的代码下一步

@JanetDelgado将你的数据图片添加到你的帖子中可能有助于我们更好地理解你的问题。嘿，伙计们，谢谢你们的帮助。我上传了更多信息和我的意思的图片。谢谢你们的帮助，但实际上我想要所有事件。不过我不想让它们连续出现。我想要c中的第一个事件D列，H列第二，L列第三，P列第四，等等每次你想要不同的东西…我的答案是否符合你的要求？如果是的，我认为如果你投票赞成，你不会生病…你的工作是考虑所有发生的事情，我想…在我对你之前的类似帖子的回答中，我提出了这一点，但我不同意你一点也不感动。你甚至什么也没说。所以，为了帮助你发布这个新主题的另一个答案，你能估计需要返回的最大栏数（包括…等）吗？@Janet Delgado:我应该理解你需要将返回列区域从四个构建到四个吗？我的意思是，下一个列将是T，下面的一个X等等？它不起作用。弹出窗口显示出现了0次，也没有复制任何内容。我是一个初学者，因此我甚至不知道你试图做什么。@FaneDuru，sure，我理解。包含代码的文件储物柜的问题是，当其他人试图查看它们时，它们已被删除（“整理”，因为它们“不再需要”）.因此，原本旨在帮助他人的帮助最终实际上是私人的，因为当时只有对应方知道交换了什么代码。