Resize Selected Range Based on Cells Format

norts55

Board Regular
Joined
Jul 27, 2012
Messages
160
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.


Document1.jpg






VBA Code:
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

Board Regular
Joined
Jul 27, 2012
Messages
160
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.
 

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
12,140
Office Version
  1. 2013
  2. 2010
Platform
  1. Windows
Try this macro:
VBA Code:
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

Board Regular
Joined
Jul 27, 2012
Messages
160
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.


1648238330437.png
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
12,140
Office Version
  1. 2013
  2. 2010
Platform
  1. Windows
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.
 

Forum statistics

Threads
1,175,824
Messages
5,899,686
Members
434,795
Latest member
tracid1987

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top