VBA – 在列中find特定单词，并将下面的单元格复制到不同的表单上

我需要一些帮助来完成以下任务：

我有源数据 –

，这是不alignment表。 我需要find一个文本（标题 – 例如帐户），并复制下面的search的单元格（帐户）两个整行，并将其粘贴在不同的工作表。 然后search下来，直到有数据的页面结束，数据应该按照时间顺序粘贴。

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

我有这个代码到目前为止，我已经stucked了一下，因为它显示我一个错误味精“运行时错误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

这篇文章没有指出你的原始代码中的错误是什么。 罗恩·罗森菲尔德在评论中已经提到了这一点。

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

截图

Answer 2

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

 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