VBA復制鏈接到列中某個關鍵字的單元格

Question

我正在嘗試自動進行銀行對帳單核對。 我需要在B列中找到一個特定的關鍵字，然后將值4列復制到該單詞的右側，然后針對該關鍵字所在的每個實例將其粘貼到單獨的工作表中。 我100％熟悉宏。 我已經從這篇文章改編了我的代碼： VBA-在列中找到特定的單詞，然后將下面的單元格復制到另一張紙上 。 當我運行它時，我僅從第一行的單元格獲取值，該單元格是B列右邊四列的副本，一直粘貼到第二個工作表的A列中，一直向下到最后一行。 我認為我的問題是循環無法正常工作（也許我需要合並一個計數，以便為我找到關鍵字的每個實例找到對應的值？），或者我設置的范圍和/或聯合設置錯誤。 嘗試使用偏移量而不是單元格會使excel無法響應。 任何幫助將不勝感激。

我在下方添加了一個圖片示例，該圖片示例將銀行轉帳條目放入excel。 我希望將“工資轉移”右側的值4列復制到第二個工作表“輸出”中。 我用X來阻止敏感信息。 抱歉，無法弄清楚如何在此處顯示圖片。

https://imgur.com/a/IjD3i0p

我確實在幾個小時前發布了一個類似的關於類型不匹配錯誤的問題，該問題試圖查找與關鍵字偏移的兩個單獨的值，我現在只是想通過查找一個偏移值來簡化它，如果我發現那，那么我可以為另一個值（一個是左邊的一列，從關鍵字開始的行向下）做它-mods，希望我發布這是可以的，如果不是的話，我深表歉意。

Dim Ws As Worksheet
Dim rngCopy As Range, aCell As Range, bCell As Range
Dim strSearch As String

strSearch = "Salary Transfer"

Set Ws = Worksheets("Summary")

With Ws
Set aCell = .Columns(2).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)

If Not aCell Is Nothing Then
    Set bCell = aCell

    If rngCopy Is Nothing Then
        Set rngCopy = .Cells(aCell.Column + 4)
    Else
        Set rngCopy = Union(rngCopy, .Cells(aCell.Column + 4))
    End If

    Do
        Set aCell = .Columns(2).FindNext(After:=aCell)

        If Not aCell Is Nothing Then
            If aCell.Address = bCell.Address Then Exit Do

            If rngCopy Is Nothing Then
                Set rngCopy = .Cells(aCell.Column + 4)
            Else
                Set rngCopy = Union(rngCopy, .Cells(aCell.Column + 4))
            End If
        Else
            Exit Do
    End If
    Loop
Else
    MsgBox SearchString & " not Found"
End If

If Not rngCopy Is Nothing Then rngCopy.Copy Sheets("Output").Columns(1)
End With

Answer 1

我很確定這可以滿足您的需求：

Dim Ws As Worksheet, rCell As Range
Dim strSearch As String: strSearch = "Salary Transfer"

For Each rCell In Intersect(Ws.UsedRange, Ws.Range("B1").EntireColumn).Cells
    If UCase(rCell.Value2) = UCase(strSearch) Then
        Sheets("Output").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = Intersect(rCell.EntireRow, Ws.Columns(6)).Value
    End If
Next rCell

有更多使用find和array的有效方法，但這應該可以使您進入終點。