Question

我需要对以下任务提供一些帮助：

我有源数据 -

Example of source data

，未与表格对齐。我需要找到一个文本（标题 - 例如帐户）并复制两行，这些行位于搜索到的单元格（帐户）下方并将其粘贴到不同的工作表上。然后向下搜索并再次执行，直到包含数据的页面结束，并且数据应按时间顺序粘贴到达。

带有“帐户”字样的单元格将始终位于A列中，但行数将不同。它还应该循环确切的单词“Account”，因为在列中可以是包含例如单词的单元格。 “付款人帐户”。

到目前为止我有这个代码而且我有点困惑，因为它向我显示错误消息“运行时错误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

请问你能帮帮我吗？

非常感谢！

Answer 1

鳕鱼就是这样的。此代码使用变体。

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

Answer 2

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

这是另一种更快的方式（与循环相比），它使用.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

<强>截图

VBA - 在列中查找特定单词并将下面的单元格复制到不同的工作表

2 个答案: