在工作簿中查找所有匹配项并将结果偏移到另一张工作表中（VBA）

Posted 2023-03-27

【中文标题】在工作簿中查找所有匹配项并将结果偏移到另一张工作表中（VBA）

【英文标题】：Find all matches in workbook and offset the results into another sheet (VBA)

【发布时间】：2021-06-20 19:24:57

【问题描述】：

如果可能的话，我想要一些帮助！目前，它会导致 excel 工作表在每次运行时崩溃，可能是因为循环没有结束。任何人都可以尝试帮助我修复我的代码吗？所有 4 张纸的行数都低于 5000 行。

我目前有一个包含 4 张工作表（工作表的数量会改变）和另外一张名为“结果”的工作表。 我设法在 B 列中查找字符串：“员工代码：-”，并获取 Y 列和 K 列中的值并将其分别粘贴到结果 A 和 B 中。 （从结果表的第 5 行开始）。 （如果 S 列和 K 列具有相同的值，则移动到下一个查找）。

然后我需要从 D 到 AN 运行的“员工代码”下方 3 和 4 行的值，并将其粘贴到 S 和 K 的值旁边

然后在粘贴结果后留下一行并重复其余的查找值。

Sub FindAndExecute()

Dim Sh As Worksheet
Dim Loc As Range
Dim i,j As Integer

i = 5
For Each Sh In ThisWorkbook.Worksheets
    With Sh.UsedRange
    Set Loc = .Cells.Find(What:="Employee Code:-")
        If Not Loc Is Nothing Then
            Do Until Loc Is Nothing
                If Loc.Offset(0, 9).Value <> Loc.Offset(0, 23).Value Then
                Sheets("Result2").Cells(i, 1).Value = Loc.Offset(0, 9).Value
                Sheets("Result2").Cells(i, 2).Value = Loc.Offset(0, 23).Value
                j = 3
                Do
                Sheets("Result2").Cells(i, j).Value = Loc.Offset(3, j - 1).Value
                Sheets("Result2").Cells(i + 1, j).Value = Loc.Offset(4, j - 
                1).Value
                j = j + 1
                Loop Until j > 35
                i = i + 3
                Else
                End If
            Set Loc = .FindNext(Loc)
            Loop
        End If
    End With
    Set Loc = Nothing
Next

End Sub

【问题讨论】：

您在尝试实施解决方案时遇到的具体问题是什么？是什么阻碍了你完成这项工作？

嗨，蒂姆，我对使用 VBA 还是很陌生。所以也许就是这样。我能够找到我需要的字符串值，但我不确定如何粘贴偏移值。使用 match 和 index 会比使用 find next 更好吗？

如果你有一些现有的代码，那么你应该将它包含在你的帖子中，即使它不完整。没有代码的问题往往会在这里结束。

我会这样做。 1. 我将遍历所有工作表并使用自动过滤器过滤 Employee Code，如图所示 HERE 并复制所有行（不做任何比较）2.一旦我的输出准备好，我将添加一个带有公式的辅助列来检查 S17<>K17 3. 我将再次在这个辅助列上使用自动过滤器来删除不需要的行。 4. 最后我会保留必要的列并删除不必要的列。

上述方法的2大好处 1.避免多次循环查找员工ID。 2. 避免在循环中多次检查S17<>K17。

【参考方案1】：

使用FindNext 检查搜索是否从头开始。

Sub FandAndExecute2()

    Const TEXT = "Employee Code:-"
    Const COL_CODE = 2 ' B
    Const COL_Y = 25 ' Y
    Const COL_K = 11 ' K
    ' copy from
    Const COL_START = "D"
    Const COL_END = "AM"
    ' copy to
    Const TARGET = "Result2"
    Const START_ROW = 5
    
    Dim wb As Workbook, ws As Worksheet, wsResult As Worksheet
    Dim rng As Range, rngSearch As Range, rngCopy As Range
    Dim r As Long, iLastRow As Long, iTarget As Long
    Dim sFirstFind As String, K, Y, n As Integer
    
    Set wb = ThisWorkbook
    Set wsResult = wb.Sheets(TARGET)
    iTarget = START_ROW
    
    ' scan sheets
    For Each ws In wb.Sheets
        If ws.Name = TARGET Then GoTo skip

        iLastRow = ws.Cells(Rows.Count, COL_CODE).End(xlUp).Row
        Set rngSearch = ws.Cells(1, COL_CODE).Resize(iLastRow)
        
        ' search for text
        With rngSearch
        Set rng = .Find(TEXT, LookIn:=xlValues)
        If Not rng Is Nothing Then
            sFirstFind = rng.Address
            Do
                r = rng.Row
                K = ws.Cells(r, COL_K)
                Y = ws.Cells(r, COL_Y)
                If K <> Y Then
                    ' copy block
                    wsResult.Cells(iTarget, "A").Value = K
                    wsResult.Cells(iTarget, "B").Value = Y
                    Set rngCopy = ws.Range(COL_START & r + 3 & ":" & COL_END & r + 4)
                    rngCopy.Copy wsResult.Cells(iTarget, "C")
                    iTarget = iTarget + 3
                    n = n + 1
                End If
                Set rng = .FindNext(rng) ' find next
             Loop While Not rng Is Nothing And rng.Address <> sFirstFind

        End If
        End With
skip:
    Next
    MsgBox n & " blocks copied to " & wsResult.Name, vbInformation
End Sub