PDA

View Full Version : [SOLVED] Deal with areas by specific string



YasserKhalil
05-19-2017, 11:41 PM
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
05-20-2017, 02:03 AM
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
05-20-2017, 02:19 AM
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
05-20-2017, 05:04 AM
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
05-20-2017, 06:52 AM
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
05-20-2017, 08:37 AM
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
05-20-2017, 10:40 AM
You are amazing and wonderful
Thank you very much for great help
Best and kind regards

MickG
05-21-2017, 04:11 AM
You're welcome