Excel Macro, read a worksheet, select range of data, copy selection - vba

Question

I need to write a macro that reads a worksheet of GeoTechnical data, selects the data based off a value in a particular row, select that row and continue reading until the end of worksheet. Once all rows are selected, I then need to copy those rows into a new worksheet. I haven't done VBA in about 10 years, so just trying to get back into things.
For example, I want the macro to read the worksheet, when column "I" contains the word "Run" on a particular row, I want to then select from that row, A:AM. Continue reading through the worksheet until the end of it. The end of the document is tricky as there are up to 10-15 blank rows sometimes in between groups of data in the worksheet. If there is more then 25 blank rows, then the document would be at the end. Once everything is selected, I then need to copy the selection for pasting into a new worksheet. Here is the code I have thus far, but I'm unable to get a selection:
Option Explicit
Sub GeoTechDB()
Dim x As String
Dim BlankCount As Integer
' Select first line of data.
Range("I2").Select
' Set search variable value and counter.
x = "Run"
BlankCount = 0
' Set Do loop to read cell value, increment or reset counter and stop loop at end 'document when there
' is more then 25 blank cells in column "I", copy final selection
Do Until BlankCount > 25
' Check active cell for search value "Run".
If ActiveCell.Value = x Then
'select the range of data when "Run" is found
ActiveCell.Range("A:AM").Select
'set counter to 0
BlankCount = 0
'Step down 1 row from present location
ActiveCell.Offset(1, 0).Select
Else
'Step down 1 row from present location
ActiveCell.Offset(1, 0).Select
'if cell is empty then increment the counter
BlankCount = BlankCount + 1
End If
Loop
End Sub

Answer 1

I see various things wrong with your code. If I understood properly what you want, this code should deliver it:
' Set Do loop to read cell value, increment or reset counter and stop loop at end 'document when there
' is more then 25 blank cells in column "I", copy final selection
Dim x As String
Dim BlankCount As Integer
Range("I2").Select
x = "Run"
BlankCount = 0
Dim found As Boolean
Dim curVal As String
Dim rowCount As Long
Dim completed As Boolean
rowCount = 2
Dim allRanges(5000) As Range
Dim rangesCount As Long
rangesCount = -1
notFirst = False
Do Until completed
rowCount = rowCount + 1
curVal = Range("I" & CStr(rowCount)).Value
If curVal = x Then
found = True
  BlankCounter = 0
rangesCount = rangesCount + 1
Set allRanges(rangesCount) = Range("A" & CStr(rowCount) & ":AM" & CStr(rowCount))
ElseIf (found) Then
If (IsEmpty(Range("I" & CStr(rowCount)).Value)) Then BlankCount = BlankCount + 1
If BlankCount > 25 Then Exit Do
End If
If (rowCount >= 5000) Then Exit Do 'In the safest-side condition to avoid an infinite loop in case of not of finding what is intended. You can delete this line
Loop
If (rangesCount > 0) Then
Dim curRange As Variant
Dim allTogether As Range
Set allTogether = allRanges(0)
For Each curRange In allRanges
If (Not curRange Is Nothing) Then Set allTogether = Union(curRange, allTogether)
Next curRange
allTogether.Select
End If
It starts iterating through column I from I2, until finding the word "Run". In this moment, it starts to count cells until reaching 25 (when the loop is exited and the corresponding range, as defined by the last row and the one at "Run", is selected). You are talking about blank cells but your code does not check that, also I am not sure what to do in case of finding a non-blank cell (restarting the counter?). Please, elaborate more on this.

Answer 2

Sub GeoTechDB()
Const COLS_TO_COPY As Long = 39
Dim x As String, c As Range, rngCopy As Range
Dim BlankCount As Integer
Set c = Range("I2")
x = "Run"
BlankCount = 0
Do Until BlankCount > 25
If Len(c.Value) = 0 Then
BlankCount = BlankCount + 1
Else
BlankCount = 0
If c.Value = x Then
If rngCopy Is Nothing Then
Set rngCopy = c.EntireRow.Cells(1) _
.Resize(1, COLS_TO_COPY)
Else
Set rngCopy = Application.Union(rngCopy, _
c.EntireRow.Cells(1) _
.Resize(1, COLS_TO_COPY))
End If
End If
End If
Set c = c.Offset(1, 0)
Loop
If Not rngCopy Is Nothing Then rngCopy.Copy Sheet2.Range("A2")
End Sub

Answer 3

i like short codes:
Sub column_I_contains_run()
If ActiveSheet.FilterMode Then Selection.Autofilter 'if an autofilter already exists this is removed
ActiveSheet.Range("$I$1:$I$" & ActiveSheet.Cells(1048576, 9).End(xlUp).Row).Autofilter Field:=1, Criteria1:="*run*"
Range("A1:AM" & ActiveSheet.Cells(1048576, 9).End(xlUp).Row).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
End Sub
now you just have to paste it into a new sheet, what could be automated also...