Resize Selected Range Based on Cells Format

[norts55]

My Title for this might not make sense as I do not know all of the VBA terminology. Hopefully I can explain enough for the experts on this forum. I have been helped many times on here and the macro I am trying to modify is one that was given to me in one of my earlier posts. This macro looks thru my sheet in column 5 for the word "Materials" and then does a Offset selection, then modifies the color formatting. This Macro works great but now I need to expand it some. Currently the Resize is always 5 rows. I am finding that I may need 5 rows, 6 rows or even 10 rows throughout my sheet. The only unique thing I can think of to end the last selected row, is the last row has unique borders. Is there a way to resize my selection based on a cells border formatting? So instead of "Resize(5, 1)" I need the macro to find the border formatting I show below and end the selection there. Hopefully someone can help here. I have searched this forum for something similar and have come up empty.

Below is the code and I have attached a image of the cell borders that would be in the last selected row.

Sub Macro1()
'
' Macro1 Macro
'

'
Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range

'What value do you want to find (must be in string form)?
  fnd = "Materials"

Set myRange = ActiveSheet.UsedRange.Columns(5)
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(What:=fnd, after:=LastCell)

'Test to see if anything was found
  If Not FoundCell Is Nothing Then
    FirstFound = FoundCell.Address
  End If

Set rng = FoundCell.Offset(1, 10).Resize(5, 1)

'Loop until cycled through all unique finds
  Do Until FoundCell Is Nothing
    'Find next cell with fnd value
      Set FoundCell = myRange.FindNext(after:=FoundCell)
    
    'Add found cell to rng range variable
      Set rng = Union(rng, FoundCell.Offset(1, 10).Resize(5, 1))
    
    'Test to see if cycled through to first found cell
      If FoundCell.Address = FirstFound Then Exit Do
      
  Loop

'Select Cells Containing Find Value
  rng.Select
 
    
    With Selection.Font
        .Color = -16566529
        .TintAndShade = 0
    End With


    
    
End Sub

 

[norts55]

I appreciate you taking the time to help me. However, I don't feel there is any reason to show any data as the data will vary significantly. I feel the data in the cells is inconsequential to the macro. The Macro searches Col E and does an offset selection to Col O, regardless of data. I just need to know if there is a way to end my selection using the border formatting I showed above.

 

[mumps]

Try this macro:

Sub SelectRange()
    Application.ScreenUpdating = False
    Dim LastRow As Long, fRow As Long, NextRow As Long, rng As Range, unionRng As Range
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With Range("E1:E" & LastRow).SpecialCells(xlCellTypeConstants)
        For i = 1 To .Areas.Count
            fRow = .Areas(i).Cells(1).Row
            If i < .Areas.Count Then
                NextRow = .Areas(i + 1).Cells(1).Row
                If .Areas(i).Cells(1) = "Materials" Then
                    If unionRng Is Nothing Then
                        Set unionRng = Range("O" & fRow + 1 & ":O" & NextRow - 3)
                    Else
                        Set unionRng = Union(unionRng, Range("O" & fRow + 1 & ":O" & NextRow - 3))
                    End If
                End If
            Else
                For Each rng In Range("O" & fRow + 1 & ":O10000")
                    If rng.Borders.Item(xlEdgeBottom).LineStyle = 1 Then
                        If unionRng Is Nothing Then
                            Set unionRng = Range("O" & fRow + 1 & ":O" & rng.Row)
                        Else
                            Set unionRng = Union(unionRng, Range("O" & fRow + 1 & ":O" & rng.Row))
                        End If
                    End If
                Next rng
            End If
        Next i
    End With
    With unionRng.Font
        .Color = -16566529
        .TintAndShade = 0
    End With
    Application.ScreenUpdating = True
End Sub

It assumes that there is a blank row between each section. Since you have not posted any data in the cells, the macro assumes that the last range selected will not go beyond row 10000. You can change that number in the code to suit your needs. If I could have seen some data in the cells, I would have been able to exactly determine that final row. That is why I asked for some data.

 

[norts55]

Ok, I really appreciate you working with me on this and being patient with me. The macro you provided doesn't quite work like I need it too. I cannot put my finger on what is the cause because I do not know enough about programming. It is probably the data as you are suggesting.

I do have another thought, maybe instead of looking for the formatting of the "xlEdgeBottom", would it be better/easier to use the "xlEdgeLeft" looking for that thin border line? My reasoning is, after the offset from the word "Materials", every cell that needs to be selected will have that thin border line on the left side. My theory is the selection could stop as soon as the left border format isn't found. I have posted a screenshot with some data. I hope this helps. Again, thank you for helping with this.

 

[mumps]

In order for me to test the macro, I would have to manually enter all the data in your "picture" into an Excel sheet. That is why I asked you to use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. This would allow me to copy/paste the data into a sheet without doing it manually. Alternately, you could upload a copy of your file to a free file sharing site and post the link to the file here. As well, you have two blank rows between some sections and one blank row between other sections. All these factors are important when trying to design a macro. The more consistent the data organization is, the easier the task of designing a macro.