VBA loop until next bold and uppercase value - excel

Question

I have a file called tg. I'd like to loop through the column A and everytime I come across an uppercase bold value, I'd like to store it as a key of my dictionary pp. The item associated is a collection of all the values up until the next uppercase and bold value. And repeat. My code doesn't seem to produce anything. Any help would be appreciated.
EDIT: I tested the my code with:
MsgBox (Pairs.Items(0).Count) and I get 0.
Function Pairs() As Dictionary
Call Files
With tg
Dim rng As Range
Dim pp As New Dictionary
Dim item As Variant
Dim arr
Dim gp As Variant
Set arr = New Collection
For Each rng In .Range("A1:A50")
If Not IsEmpty(rng) And IsUpper(rng.Value) And rng.Value <> "NULL" And rng.Font.Bold = True Then
gp = rng.Value
Do While Not IsEmpty(rng) And Not IsUpper(rng.Value) And rng.Font.Bold = True '
arr.Add rng.Value
Loop
pp.Add gp, arr
End If
Next rng
Set Pairs = pp
End With
End Function

Answer 1

Please, use the next faster way. It find the first Bolded cell, checks if isUpper and place in a dictionary (as key) the matched such cells value and the range in between as item:
Function Pairs() As Scripting.Dictionary
Dim tg As Worksheet, rng As Range, cB As Range, firstAddress As String, pp As New Scripting.Dictionary
Set tg = ActiveSheet 'use here the sheet you need
Set rng = tg.Range("A1:A50")
With Application.FindFormat
.Clear
.Font.Bold = True
End With
Set cB = rng.Find(what:=vbNullString, Searchformat:=True)
Dim prevRow As Long, prevKey As String
If Not cB Is Nothing Then
If IsUpper(cB.value) Then
firstAddress = cB.Address:
Do
If prevRow <> 0 Then Set pp(prevKey) = tg.Range("A" & prevRow & ":A" & cB.row - 1)
pp.Add cB.value, 1: prevRow = cB.row: prevKey = cB.value
Do
Set cB = rng.Find(what:=vbNullString, After:=cB, Searchformat:=True)
Loop Until IsUpper(cB.value)
Loop While cB.Address <> firstAddress
End If
Set pp(prevKey) = tg.Range("A" & prevRow & ":A50")
Else
MsgBox "No bolded cell in Uppercase has been found..."
End If
Set Pairs = pp
End Function
Function IsUpper(s) As Boolean
With CreateObject("VBScript.RegExp")
.Pattern = "^[^a-z]*$"
IsUpper = .test(s)
End With
End Function
It can be tested with something like:
Sub testPairs()
Dim i As Long, pp As Scripting.Dictionary
Set pp = Pairs
If pp.count = 0 Then Exit Sub
For i = 0 To pp.count - 1
Debug.Print pp.Keys()(i), pp.Items()(i).Address
Debug.Print Join(Application.Transpose(pp.Items()(i).value), "|")
Next i
End Sub
For the last occurrence it uses the range starting below it and the last cell in the range. If you will not use something static ("A1:A50"), the calculated last cell can be used...
If you need/want a collection instead of range as a dictionary item, it can be done, but in the way I tried handling the processing the range looks the most appropriate. You can easily place the range in an array and do whatever you need with it...
Please, send some feedback after testing it.
Your loop starting with Do While Not IsEmpty(rng) needs an incrementation, otherwise will exit immediately in case of a match but will stay in a continuous loop if not...
If you like more your way, or want better understanding where the mistake is, please replace this part:
Do While Not IsEmpty(rng) And Not IsUpper(rng.Value) And rng.Font.Bold = True '
arr.Add rng.Value
Loop
Firstly a new variable should be declared `Dim i As Long`.
Then replace with:
Do
arr.Add rng.Offset(i).value
i = i + 1
Loop Until IsUpper(rng.Offset(i).value) And rng.Offset(i).Font.Bold = True Or rng.Offset(i).value = ""
i = 0

Answer 2

Do is not oK use If, and a problem in For.
For Each rng In .Range("A1:A50").Cells