Find a value and then copy cells relative to the value

[daithiboy]

Hi All,

I regularly receive a rather poorly put together spreadsheet and I am putting together some macros to make it usable!

I've run into an issue where there is a merged title row that will always contain the word "Clinic". This row number can change regularly. The rows that I wish to copy start two rows below the title row.

I have been trying to write a macro which will search for "*Clinic*" and then offset down by two rows and copy everything from there to the last row, but have failed miserably

I hope someone can help as I have wasted quite a bit of office hours with this today!!

Many thanks in advance.
Dave

 

[mumps]

Try:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim ClinicRow As Long
    ClinicRow = ActiveSheet.UsedRange.Find("Clinic", LookIn:=xlValues, lookat:=xlPart).Row
    Dim lCol As Long
    lCol = ActiveSheet.UsedRange.Columns.Count
    Range("H" & ClinicRow + 2) = "Regular"
    Range("H" & ClinicRow + 2).Copy Range("H" & ClinicRow + 2 & ":H" & LastRow)
    Range(Cells(ClinicRow + 2, 1), Cells(LastRow, lCol)).Copy Sheets("Sheet2").Cells(1, 1)
    Application.ScreenUpdating = True
End Sub

 

[Yongle]

My code amended
- using columnA to determine last row
- copy instruction included
- paste instruction should be added

Sub CopyRows()
    Dim r As Long
    With ActiveSheet
        r = .Cells.Find("*clinic*").Row + 2
        .Range("A" & r, .Range("A" & Rows.Count).End(xlUp)).Offset(, 7).Value = "Regular"
        .Range("A" & r, .Range("A" & Rows.Count).End(xlUp)).EntireRow.Copy
    End With
End Sub