CODEWITHSUNDEEP
vbaexcel
M Mayer
M Mayer

Reputation: 17

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

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

Upvotes: 0

Views: 23434

Answers (3)

user2480047
user2480047

Reputation:

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.

Upvotes: 0

Max
Max

Reputation: 759

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...

Upvotes: 0

Tim Williams
Tim Williams

Reputation: 166790

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

Upvotes: 0

Related Questions