Deal with areas by specific string

[YasserKhalil]

Hello everyone
I have specific string "Project:/" in column A and I need to deal with different areas of each range
Example: the string is in A15 then A21 then A50 then A61
so I need a way to deal with each area separately so :
** A15 to A20 (this is an area)
** A21 to A49 (this is an area)
** A50 to A60 (this is an area)
** A61 to A & last row (this is an area)

Thanks advanced for help

[MickG]

Try this:-
This code will give you each range area, starting with word "Project:/".

Sub MyArea()
Dim Rng As Range, Dn As Range, R As Range, nRng As Range
Set Rng = Range(Range("A15"), Range("A" & Rows.Count).End(xlUp))
 Rng.Replace What:="Project:/", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True
  Set nRng = Rng.SpecialCells(xlCellTypeConstants)
    Rng.Replace What:="", Replacement:="Project:/", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True
        MsgBox nRng.Address
For Each Dn In nRng.Areas
    Set Dn = Dn.Offset(-1).Resize(Dn.Count + 1)
      MsgBox Dn.Address
    For Each R In Dn
        'MsgBox R.Value
    Next R
Next Dn
End Sub

[YasserKhalil]

Thanks a lot for this great solution Mr. MickG
I have two notes : first the string may be part of the cell not xlWhole so I think it would be xlPart
Another point : there are empty cells in between and after testing the code I found these empty cells filled with the string .. Can this be avoided?

[MickG]

This is better :-
Ref your File :- Data Of areas shown Across sheet, Starting "B1"

Sub nArea()
Dim Rng As Range, Dn As Range, n As Long, Q As Variant, Ac
Dim K As Variant, c As Long
Set Rng = Range(Range("A4"), Range("A" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
    If Dn.Value Like "*Project:/" Then
       n = n + 1
       .Add n, Dn
    Else
       Set .Item(n) = Union(.Item(n), Dn)
    End If
Next
 Ac = 1
For Each K In .keys
    Ac = Ac + 1
    Cells(1, Ac + 1).Resize(.Item(K).Count).Value = .Item(K).Value
Next K
End With
End Sub

[YasserKhalil]

That's wonderful Mr. MickG
I liked it a lot

But in fact I didn't know how to loop through each area .. I mean I need to learn how to loop through each area separately
I imagine a main loop that helps me out to recognize the desired area than another loop to loop through the area itself

The same idea as in post #2

For Each R In Dn 
             'MsgBox R.Value
        Next R

[MickG]

Change second part of code as below to loop through each separate Area:-

dim P as Range
ac = 1
For Each K In .keys
    ac = ac + 1: c = 0
    For Each P In .Item(K)
        c = c + 1
        Cells(c, ac + 1).Value = P
    Next P
Next K

Or for another option Try this for same result:-

Sub NewArray()
Dim a() As Variant, i As Long, j As Long, n As Long, ac As Long
Dim Rng As Range, Dn As Range
Set Rng = Range(Range("A4"), Range("A" & Rows.Count).End(xlUp))
ReDim a(1 To Rng.Count)
For Each Dn In Rng
    If Dn.Value Like "*Project:/" Then
       i = i + 1: j = 0
        a(i) = MakeArray(1, Rng.Count)
    End If
         j = j + 1
         a(i)(j) = Dn.Address
Next Dn
For n = 1 To i
 For ac = 1 To UBound(a(n))
    If Not IsEmpty(a(n)(ac)) Then
        Cells(ac, n + 2) = Range(a(n)(ac)).Value
    End If
 Next ac
  Next n
 End Sub
Function MakeArray(lower As Long, upper As Long) As Variant
Dim B As Variant
    ReDim B(lower To upper)
    MakeArray = B
End Function

Regards Mick

[YasserKhalil]

You are amazing and wonderful
Thank you very much for great help
Best and kind regards

[MickG]

You're welcome