selecting a specific range in excel - vba

Question

I am realy new in Vba. I have a long data series in excel. but I want to select and cut some specific data range which are in column A and start with "MIN" till 33 rows after that. In each column there are 60 data series with different lengthen but all start with the row filled "MIN" till 33 rows after that. Between the range I want to select there are some other rows with data which aren't my goal.
I could copy all my ranges by hand but it takes time. I have 200 files that each files has 20000 rows and its really terrible to do by hand. All I could find is this code which i should at first find the row which has cells filled "MIN". Then I fill the range in this code by hand. but it takes time too. I want to write a code which :
1. find all cells filled "MIN"
2. Select the row which has "MIN"``
3.extend selection till 33 rows
4.copy all ranges it finds
thank you in advance.
This code works too but just extract the rows which has cell "min" and copy them in another sheet. but i want to extend the selection from the row it finds (has cell "min") till 33 rows after that.
Public Sub FindAndCopyit()
Dim Rng As Range
Dim rCell As Range
Dim copyRng As Range
Dim LCell As Range
Dim WB As Workbook
Dim srcSH As Worksheet
Dim destSH As Worksheet
Dim sFirst As String
Dim CalcMode As Long
Const strSearch As String = "MIN"
Set WB = ActiveWorkbook
Set srcSH = WB.Sheets("Find")
Set destSH = WB.Sheets("final")
Set Rng = srcSH.Range("A1:G20000")
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Set rCell = Rng.Find(strSearch)
If Not rCell Is Nothing Then
Set copyRng = rCell.EntireRow
sFirst = rCell.Address
Do
Set rCell = Rng.FindNext(rCell)
If Not rCell Is Nothing And _
rCell.Address <> sFirst Then
Set copyRng = Union(rCell.EntireRow, copyRng)
End If
Loop Until rCell Is Nothing Or sFirst = rCell.Address
End If
Set LCell = destSH.Cells(Rows.Count, "A").End(xlUp)(2)
If Not copyRng Is Nothing Then
With copyRng
.Copy Destination:=LCell
.Delete
End With
End If
With Application
.CutCopyMode = False
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
would you please help me to fix it?

Answer 1

Try replacing:
Set copyRng = rCell.EntireRow
with
Set copyRng = Range(rCell, rCell(33, 1)).EntireRow