Поиск определенного диапазона для копирования на основе ключевого слова

Question

Здравствуйте, у меня есть следующий код VBA в Excel

On Error Resume Next

Dim wk As Worksheet
Set wk = Sheets("ABC")
With Sheets("DEF")
   .Range("A6", .Columns("A").Find("", , xlValues, xlWhole).Offset(-1)).EntireRow.Copy _
    wk.Range("A" & wk.Cells(Cells.Rows.Count, "A").End(xlUp).Row + 1)
End With

Цель этого кода - начать с ячейки A6 в листе DEF (A6 содержит слово "Дата") и скопировать диапазон листа под A6 до первой пустой строки, а затем вставить в лист ABC .

Не могли бы вы помочь мне улучшить этот код, чтобы вместо этого найти слово «Дата», которое в настоящее время находится в ячейке A6, и выполнить эту же задачу? (то есть, допустим, в следующий раз, когда в ячейке А1 появится «Дата»)

Спасибо.

Answer 1

Вам необходимо объявить свои переменные («Дата» и последняя строка).

Dim lRow As Long
Dim fWord As Range

Dim wk As Worksheet
Set wk = Sheets("ABC")

    With Sheets("DEF")
        lRow = Range("A" & Rows.Count).End(xlUp).Row
        Set fWord = Columns("A").Find(what:="Date", LookIn:=xlValues, lookat:=xlWhole)

        If Not fWord Is Nothing Then Rows(fWord.Row & ":" & lRow).Copy _
        wk.Range("A" & wk.Cells(Cells.Rows.Count, "A").End(xlUp).Row + 1)
    End With

Answer 2

Sub tgr()

    Dim wb As Workbook
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim rDate As Range
    Dim rLast As Range
    Dim sFind As String

    Set wb = ActiveWorkbook
    Set wsSource = wb.Sheets("DEF")
    Set wsDest = wb.Sheets("ABC")
    sFind = "Date"

    With wsSource
        Set rDate = .Cells.Find(sFind, .Cells(.Rows.Count, .Columns.Count), xlValues, xlWhole)
        If rDate Is Nothing Then
            MsgBox "No cell containing text """ & sFind & """ found in sheet '" & .Name & "'"
            Exit Sub
        End If
        Set rLast = .Cells.Find("*", .Range("A1"), xlFormulas, , , xlPrevious)
        If rLast.Row <= rDate.Row Then
            MsgBox "No data found after """ & sFind & """ in sheet '" & .Name & "'"
            Exit Sub
        End If
    End With

    wsSource.Range(rDate.Offset(1), rLast).EntireRow.Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)

End Sub