搜索匹配两次相同列的 2 个关键字并将结果复制到另一个 sheet

Question

我被卡住了，我不知道要使用什么代码，所以我可以针对 2 个不同的关键字在同一列中搜索两次，然后从起始单元格按顺序将数据从同一行复制到另一个电子表格。有关详细信息，这就是我正在尝试做的事情。

将搜索限制在工作表的范围内（例如Sheet 1 B1:N:200）
在限制范围 Sheet1 的第 8 列 (I) 中搜索关键字（“商品”）
复制在找到实例“Goods”的同一行的第 2 (C) 和第 5 列 (F) 中找到的数据
将 Sheet 1 - column 2 的值粘贴到 Sheet2 - Column 3（仅无格式值），以及 Sheet 1 column 5 to Sheet 2 Column4 (with format and values) on a specific starting point (ex. Sheet 2 - B3) Next Match Result will be Sheet 2 - B4 等等

5.再次搜索 Sheet1 的第 8 列，从顶部开始搜索关键字（“服务”）(B1:N1)

6.Copy 在同一行的 第 2 (C) 和第 5 列 (F) 中找到的数据 找到实例“服务”

将 Sheet 1 - column 2 的值粘贴到 Sheet2 - Column 3（仅无格式值），以及 Sheet 1 column 5 to Sheet 2 Column4 (with format and values) to next row after the last PASTE from "Goods" was done. （前最后一行匹配粘贴是 C35 和 D35 新发现的值应该粘贴在 C36 和 D36 中）结束输出应该是所有“商品”结果，然后是“服务”结果

我希望我已经清楚地传达了我需要的东西

我正在尝试处理我在此处找到的这段代码，但我只是不知道如何插入服务的第二个搜索循环。如何粘贴到工作表 2 中的特定单元格，如何跟随最后一行对于服务粘贴

        Sub CopyCells
    
    Dim lngLastRowSht1 As Long
    
    Dim lngLastRowSht2 As Long
    
    Dim counterSht1 As Long
    Dim counterSht2 As Long
    
    
    With Worksheets(1)
    
        lngLastRowSht1 = .Cells(.Rows.Count, 8).End(xlUp).Row
    
        lngLastRowSht2 = Worksheets(2).Cells(Worksheets(2).Rows.Count, 5).End(xlUp).Row
    
            For counterSht1 = 1 To lngLastRowSht1
    
                For counterSht2 = 1 To lngLastRowSht2
    
                    If Sheets(1).Range("" & (counterSht1)).Value = "Goods" Then
    
                        Sheets(2).Range("B" & (counterSht2), "D" & (counterSht2)).Value = Sheets(1).Range("C" & counterSht1, "D" & counterSht1).Value
    
                                        End If
    
                Next counterSht2
    
            Next counterSht1
    
            
    
    End With
    
    End Sub

编辑1

根据克里斯爵士的要求，它应该是这样的

@CDP1802 根据需要解决了此查询的最佳答案。

我了解到我需要 2 个计数器才能工作 :) 我还学习了如何正确标记目标目的地。

感谢这个社区:)

Answer 1

您可以制作两个例程：一个用于服务，一个用于商品。但是那个代码和上面的代码不是很有效。

由于服务和商品在同一列中，请尝试使用自动筛选器：

Sheets(2).UsedRange.autofilter Field:=8, Criteria1:=Array("Goods", "Services"), VisibleDropDown:=False, Operator:=xlFilterValues
Sheets(2).UsedRange.SpecialCells(xlCellTypeVisible).Copy
Sheets(1).Range("A1").PasteSpecial
Application.CutCopyMode = False

Answer 2

每次复制后增加目标行。

Option Explicit
Sub CopyCells()

    Const ROW_START = 3

    Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet
    Dim n As Long, r As Long, lastrow1 As Long, lastrow2 as Long
    Dim keywords, word, t0 As Single: t0 = Timer
    keywords = Array("Goods", "Services")
    
    Set wb = ThisWorkbook
    Set ws1 = wb.Sheets(1)
    Set ws2 = wb.Sheets(2)
    lastrow2 = ROW_START
    
    Application.ScreenUpdating = False
    With ws1
        lastrow1 = .Cells(.Rows.Count, "I").End(xlUp).Row
        For Each word In keywords
            For r = 1 To lastrow1
                If Len(.Cells(r, "I")) = 0 Then
                    Exit For
                ElseIf .Cells(r, "I") = word Then
                    'Sht1 col 2 to Sht2 Col 3 (no format values only)
                    'Sht1 col 5 to Sht2 Col 4 (with format and values)
                    ws2.Cells(lastrow2, "C") = .Cells(r, "B")
                    ws2.Cells(lastrow2, "D") = .Cells(r, "E")
                    .Cells(r, "E").Copy
                    ws2.Cells(lastrow2, "D").PasteSpecial xlPasteFormats
                    lastrow2 = lastrow2 + 1
                    n = n + 1
                End If
            Next
        Next
    End With
    Application.ScreenUpdating = True
    
    MsgBox r - 1 & " rows scanned " & vbLf & n & " rows copied", _
    vbInformation, Format(Timer - t0, "0.0 secs")
End Sub

搜索匹配两次相同列的 2 个关键字并将结果复制到另一个 sheet

Search match twice 2 keywords same column and copy result to another sheet

excel

vba

match