VBA loop until next bold and uppercase value-CodePudding

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

CodePudding user response：

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

CodePudding user response：

Do is not oK use If, and a problem in For.

   For Each rng In .Range("A1:A50").Cells