VBA Word - Extract questions from document and consolidate them at one place

The following code extracts questions from word document based on the format of questions. Each question has specific font style, color, size etc. Based on this information, each question is stored in Dictionary object: question number is key and question is value. Look at the code below which extracts questions from document and place them at top of the document to consolidate them at one place:

Sub ExtractQuestionsAndMoveToTopPerfectUsingDictionary()
    Dim doc As Document
    Dim para As Paragraph
    Dim questionsDict As Object
    Dim questionRangesDict As Object
    Dim k As Integer
    Dim questionText As String
    Dim rngQStart As Range
    Dim topRng As Range
    Dim key As Variant
    Dim result As Variant
    
    result = MsgBox("Continue?", vbOKCancel, "Chat GPT Document Maker")
    If result = vbOK Then
        ' Initialize the document and dictionaries
        Set doc = ActiveDocument
        Set questionsDict = CreateObject("Scripting.Dictionary")
        Set questionRangesDict = CreateObject("Scripting.Dictionary")
        k = 1
        questionText = ""
    
        ' Loop through each paragraph in the document
        For Each para In doc.Paragraphs
            ' Check if the paragraph has the required format
            With para.Range.Font
                If .Name = "Georgia" And .Size = 10 And .Bold = True And .Color = RGB(0, 0, 255) Then
                    ' Store the starting range of the question
                    If questionText = "" Then
                        Set rngQStart = para.Range.Duplicate
                    End If
                    ' Append the plain text of the paragraph to the question text
                    questionText = questionText & para.Range.Text
                ElseIf Len(questionText) > 0 Then
                    ' Store the collected question text in the dictionary
                    questionsDict.Add k, questionText
                    questionRangesDict.Add k, rngQStart
                    k = k + 1
                    questionText = ""
                End If
            End With
        Next para
    
        ' If there's any remaining question text, add it to the dictionaries
        If Len(questionText) > 0 Then
            questionsDict.Add k, questionText
            questionRangesDict.Add k, rngQStart
        End If
    
        ' Set the range to the start of the document to insert questions
        Set topRng = doc.Range(0, 0)
    
        ' Insert questions and hyperlinks at the top of the document in reverse order
        For i = questionsDict.Count To 1 Step -1
            ' Insert question with key
            topRng.InsertAfter questionsDict(i)
            
            ' Move the range to the end of the newly added text
            Set topRng = doc.Range(0, 0)
            topRng.Collapse wdCollapseEnd
            
            ' Add a bookmark and hyperlink
            AddHyperlink topRng, "Question" & i, questionRangesDict(i)
            topRng.InsertAfter vbCrLf
        Next i
    End If
End Sub

Now, the consolidated questions are provided hyperlinks to reach to their answers.

Sub AddHyperlink(rng As Range, displayText As String, targetRange As Range)
    ' Add a bookmark at the target range so that the hyperlink can reference it
    On Error Resume Next
    ActiveDocument.Bookmarks.Add Name:=displayText, Range:=targetRange
    On Error GoTo 0

    ' Add a hyperlink to the specified range
    ActiveDocument.Hyperlinks.Add _
        Anchor:=rng, _
        Address:="", _
        SubAddress:=displayText, _
        TextToDisplay:=displayText
End Sub

VBA Excel - delete blank rows from Excel sheet:

The following code deletes blank rows from Excel sheet:

Sub pDelBlnkRws()
    Dim lngMaxR As Long
    Dim lngC As Long
    Dim rngStart As Range
    
    On Error GoTo lblError3
    
    Set rngStart = Sheet1.Range("A" & Sheet1.Rows.CountLarge)
    
    For lngC = 1 To 11
        If rngStart.End(xlUp).Row > lngMaxR Then
            lngMaxR = rngStart.End(xlUp).Row
        End If
        Set rngStart = rngStart.Offset(ColumnOffset:=1)
    Next
       
    For lngC = lngMaxR To 1 Step -1
        With Sheet1
            If Application.WorksheetFunction.CountA(.Range("A" & lngC).EntireRow) = 0 Then
                .Range("A" & lngC).EntireRow.Delete
            End If
        End With
    Next
    
lblError3:
If Err.Number <> 0 Then
    MsgBox "Error Number:" & Err.Number & vbCrLf & "Error Description: " & Err.Number
End If
End Sub