Поиск определенного заголовка и копирование определенного количества записей под ним

Question

Я пытаюсь найти определенный заголовок (заголовок 1 в этом примере) и скопировать определенное количество ячеек ниже этого заголовка в диапазон.Текст самого заголовка не должен копироваться, но все, что находится под ним.

Следующий код работает, но копирует слишком много строк.Когда я использую For x = 0 To 3, он копирует следующие 10 строк ниже «Заголовок 1» вместо только 3. Я не могу найти свою ошибку.

Sub FindCopyPasteV2()

    With Worksheets("Sheet1").Range("A:FF")

        Dim FindEQ3 As Range
        Dim TestR As Range
        Dim x As Long

           Set FindEQ3 = .Find(What:="Header 1", LookAt:=xlWhole, MatchCase:=True, SearchFormat:=False)

              For x = 0 To 3

                 Set FindEQ3 = FindEQ3.Resize(FindEQ3.Rows.Count + x).Offset(1)
                 Set TestR = .Range("K" & 5 + x)

                 FindEQ3.Copy TestR

              Next x

    End With

End Sub

Answer 1

Я думаю, что ваша проблема в том, что вы делаете что-то дважды. Цель цикла - убедиться, что скопированы 3 строки, но на самом деле FindEQ3.Resize уже делает это.

Этот код должен быть ближе к тому, что вы хотите. Я в основном только что снял петлю.

Sub FindCopyPasteV2()

    With Worksheets("Sheet1").Range("A:FF")

        Dim FindEQ3 As Range
        Dim TestR As Range

        Const NUM_ROWS_COPY As Long = 3

        Set FindEQ3 = .Find(What:="Header 1", LookAt:=xlWhole, MatchCase:=True, SearchFormat:=False)

        Set FindEQ3 = FindEQ3.Resize(NUM_ROWS_COPY).Offset(1)
        Set TestR = .Range("K" & 5)

        FindEQ3.Copy TestR


    End With

End Sub

Answer 2

Я не уверен, почему вы хотите использовать цикл for для копирования нескольких ячеек. Пожалуйста, найдите ниже код. Это должно найти заголовок, который вы ищете, а затем «скопировать» значения в другое место.

Option Explicit

Sub FindCopyPaste()

    Dim mRng As Range
    Dim fRng As Range
    Dim xOff As Long
    Dim mSheet As Worksheet

    'number of cells to "copy" across
    xOff = 3

    Set mSheet = Sheets("Sheet1")
    Set mRng = mSheet.Range("A:FF")
    Set fRng = mRng.Find(What:="Header 1", LookAt:=xlWhole, MatchCase:=True, SearchFormat:=False)


    If Not fRng Is Nothing Then
        'if it finds the header
        'now set values
        mSheet.Range("K5").Resize(xOff, 1).Value = mSheet.Range(mSheet.Cells(fRng.Row + 1, fRng.Column), mSheet.Cells(fRng.Row + xOff, fRng.Column)).Value
    Else
        MsgBox "Error! Could not find Header 1!"
    End If

End Sub