vba 在列中查找单词并在不同的工作表上复制下面的行

Find word in column and copy lines below on different sheet

提问by Srpic

I have source data which are not aligned to table.

我有与表格不对齐的源数据。

I want to find text (e.g. Account), copy the two whole lines below the cell with the found text (Account) and paste them on a different Sheet. Then search down and do again until the data ends. Data should be pasted in the order it is reached.

我想查找文本（例如帐户），将单元格下方的两整行与找到的文本（帐户）一起复制并将它们粘贴到不同的工作表上。然后向下搜索并再次执行，直到数据结束。数据应按到达的顺序粘贴。

The cell with word "Account" will be always in the column A. The search should be for the exact word "Account", because in the column can be cells which contain e.g. "Payer account".

带有“帐户”一词的单元格将始终位于 A 列中。搜索应该是准确的“帐户”一词，因为该列中可能包含包含“付款人帐户”等单元格。

This code shows me an error msg

此代码向我显示了错误消息

"Run-time error 438 - object doesnt support this property or method"

“运行时错误 438 - 对象不支持此属性或方法”

Private Sub Search_n_Copy()

Dim LastRow As Long
Dim rng As Range, C As Range

With Worksheets("INPUT_2") ' <-- here should be the Sheet's name
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
    Set rng = .Range("A1:A" & LastRow) ' set the dynamic range to be searched

    ' loop through all cells in column A and copy below's cell to sheet "Output_2"
    For Each C In rng
        If C.Value = "Account" Then
            C.Offset(-1, 0).Copy C.Offset.OUTPUT_2(-7, -1) ' use offset to put value in sheet "Output_2", column E
        End If
    Next C
End With

End Sub

采纳答案by Siddharth Rout

This post doesn't point out what the error in your original code is. Ron Rosenfeld has already covered that in the comment.

这篇文章没有指出原始代码中的错误是什么。Ron Rosenfeld 已经在评论中提到了这一点。

Here is another faster way (as compared to looping) which uses .Find/.FindNextto achieve what you want. It also doesn't copy the rows in a loop but copies in the end.

这是另一种更快的方法（与循环相比），用于.Find/.FindNext实现您想要的。它也不会在循环中复制行，而是在最后复制。

Private Sub Search_n_Copy()
    Dim ws As Worksheet
    Dim rngCopy As Range, aCell As Range, bcell As Range
    Dim strSearch As String

    strSearch = "Account"

    Set ws = Worksheets("INPUT_2")

    With ws
        Set aCell = .Columns(1).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 = .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2))
            Else
                Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2)))
            End If

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

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

                    If rngCopy Is Nothing Then
                        Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2))
                    Else
                        Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2)))
                    End If
                Else
                    Exit Do
                End If
            Loop
        Else
            MsgBox SearchString & " not Found"
        End If

        '~~> I am pasting to Output sheet. Change as applicable
        If Not rngCopy Is Nothing Then rngCopy.Copy Sheets("Output").Rows(1)
    End With
End Sub

Screenshot

截屏

回答by Dy.Lee

The codle would be like this. This code Use variant.

代码会是这样的。此代码使用变体。

Private Sub Search_n_Copy()

    Dim LastRow As Long
    Dim rng As Range, C As Range
    Dim vR(), n As Long, k As Integer, j As Integer
    Dim Ws As Worksheet

    With Worksheets("INPUT_2") ' <-- here should be the Sheet's name
        .Columns("e").ClearContents
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
        Set rng = .Range("A1:A" & LastRow) ' set the dynamic range to be searched

        ' loop through all cells in column A and copy below's cell to sheet "Output_2"
        For Each C In rng
            If C.Value = "Account" Then
                For j = 1 To 2
                    n = n + 1
                    ReDim Preserve vR(1 To 6, 1 To n)
                    For k = 1 To 6
                        vR(k, n) = C.Offset(j, k - 1) ' use offset to put value in sheet "Output_2", column E
                    Next k
            End If
        Next C
        If n > 0 Then
            Set Ws = Sheets.Add '<~~~  Sheets("your sheet name")
            With Ws
                .Range("a1").Resize(n, 6) = WorksheetFunction.Transpose(vR)
            End With
        End If
    End With

End Sub