Each question which is highlighted in Blue color and is Georgia, Bold and 10 size will be extracted at top of the document. Also hyperlinks will be created to reach at top and back to the question.
Sub ExtractQuestionsAndMoveToTopPerfectUsingDictionary_TwoWayHyperlinks()
Dim doc As Document
Dim para As Paragraph
Dim questionsDict As Object ' Stores question number (Key) and full question text (Value)
Dim questionRangesDict As Object ' Stores question number (Key) and original Range object (Value)
Dim k As Integer
Dim questionText As String
Dim rngQStart As Range
Dim topRng As Range ' This will be our dynamic insertion point for the list
Dim result As Variant
Dim consolidatedListBookmarkName As String
' Define a unique bookmark name for the top consolidated list
consolidatedListBookmarkName = "ConsolidatedQuestionsListTop"
result = MsgBox("Continue?", vbOKCancel, "Chat GPT Document Maker")
If result = vbCancel Then Exit Sub ' Exit if user cancels
' Initialize the document and dictionaries
Set doc = ActiveDocument
Set questionsDict = CreateObject("Scripting.Dictionary")
Set questionRangesDict = CreateObject("Scripting.Dictionary")
k = 1 ' Initialize question counter
questionText = "" ' Initialize collected question text
' --- Clear existing question-related bookmarks before starting ---
' This prevents errors if the macro is run multiple times or if old bookmarks exist.
Dim bm As Bookmark
For Each bm In doc.Bookmarks
' Check if bookmark name starts with "Question_" (our question bookmarks)
' or the consolidated list bookmark name
If InStr(bm.Name, "Question_") = 1 Or bm.Name = consolidatedListBookmarkName Then
On Error Resume Next ' In case a bookmark cannot be deleted for some reason
bm.Delete
On Error GoTo 0
End If
Next bm
' Loop through each paragraph in the document to identify and collect questions
For Each para In doc.Paragraphs
' Check if the paragraph has the required formatting (Times New Roman, 12pt, Bold, Blue)
With para.Range.Font
If .Name = "Georgia" And .Size = 10 And .Bold = True And .Color = RGB(0, 0, 255) Then
' This paragraph is part of a question
If questionText = "" Then
' If this is the very first part of a new question, store its starting range
Set rngQStart = para.Range.Duplicate
End If
' Append the plain text of the paragraph to the current question text.
' Trim and replace vbCr to ensure clean text without extra line breaks within the question.
questionText = questionText & Trim(Replace(para.Range.Text, vbCr, ""))
ElseIf Len(questionText) > 0 Then
' This paragraph does NOT match the question format, and we have collected a question.
' This signifies the end of the current question. Store it.
questionsDict.Add k, questionText
questionRangesDict.Add k, rngQStart.Duplicate ' Store a duplicate range to preserve its reference
k = k + 1 ' Increment for the next question
questionText = "" ' Reset collected question text
Set rngQStart = Nothing ' Clear the range reference
End If
End With
Next para
' After the loop, check if there's any remaining question text that wasn't stored
' (e.g., if the document ends with a question)
If Len(questionText) > 0 Then
questionsDict.Add k, questionText
questionRangesDict.Add k, rngQStart.Duplicate
End If
' --- Prepare the document for inserting the consolidated list ---
' Ensure the list starts on a fresh page at the very beginning of the document.
' This only inserts a page break if there's existing content at the document's start.
If doc.Content.Start <> 0 Then
doc.Range(0, 0).InsertBreak wdPageBreak
End If
' Set the initial insertion point for the list at the very beginning of the document (page 1, position 0)
Set topRng = doc.Range(0, 0)
' Add a bookmark at the very top of the document for the consolidated list.
' This is the target for hyperlinks from individual questions.
On Error Resume Next
doc.Bookmarks.Add Name:=consolidatedListBookmarkName, Range:=doc.Range(0, 0)
On Error GoTo 0
' Add a title for the list
topRng.InsertAfter "List of Consolidated Questions:" & vbCrLf & vbCrLf
' Move the insertion point to the end of the title, so subsequent content is added after it.
topRng.Collapse Direction:=wdCollapseEnd
' --- Insert questions and hyperlinks at the top of the document ---
' Iterate from the last question collected to the first for correct ascending display order.
For k = questionsDict.Count To 1 Step -1
Dim currentQuestionFullText As String
Dim targetBookmarkName As String
Dim targetQuestionRange As Range
currentQuestionFullText = questionsDict(k) ' Get the full question text from the dictionary
Set targetQuestionRange = questionRangesDict(k) ' Get the original range for the bookmark
' Define the bookmark name for the original question's location.
targetBookmarkName = "Question_" & k
' Add a bookmark to the original question's location in the document.
' This is the destination for the hyperlink from the consolidated list.
On Error Resume Next
doc.Bookmarks.Add Name:=targetBookmarkName, Range:=targetQuestionRange
On Error GoTo 0
' Prepare the full text that will be displayed as the hyperlink in the consolidated list.
Dim displayTextForHyperlink As String
displayTextForHyperlink = "Question " & k & ": " & currentQuestionFullText
' Create a temporary range for inserting the hyperlink and line break at the current topRng's start.
Dim insertPoint As Range
Set insertPoint = doc.Range(topRng.Start, topRng.Start)
' Insert the hyperlink (with the full question text)
doc.Hyperlinks.Add _
Anchor:=insertPoint, _
Address:="", _
SubAddress:=targetBookmarkName, _
TextToDisplay:=displayTextForHyperlink
' Insert a line break after the hyperlink you just inserted
insertPoint.InsertAfter vbCrLf
' Update topRng to encompass the newly inserted content.
Set topRng = doc.Range(topRng.Start, topRng.End + Len(displayTextForHyperlink) + 2) ' +2 for vbCrLf
Next k
' Add a line break after the last question in the consolidated list for proper spacing.
If questionsDict.Count > 0 Then
topRng.InsertAfter vbCrLf
End If
' --- NOW, ADD HYPERLINKS TO THE ORIGINAL QUESTIONS ---
' Iterate through the stored original question ranges
For k = 1 To questionRangesDict.Count
Set rngQStart = questionRangesDict(k) ' Get the original question's range
' Ensure the range is valid and exists before adding a hyperlink
' (e.g., if content was cut/deleted after initial collection)
If rngQStart.StoryType = wdMainTextStory Then ' Check if it's still in the main body
' Add a hyperlink to the original question.
' The anchor is the original question's text.
' The subaddress is the bookmark at the top of the consolidated list.
' The text displayed is the original question's text.
On Error Resume Next ' Handle potential errors if range is somehow problematic
doc.Hyperlinks.Add _
Anchor:=rngQStart, _
Address:="", _
SubAddress:=consolidatedListBookmarkName, _
TextToDisplay:=questionsDict(k) ' Use the stored full question text as display text
On Error GoTo 0
End If
Next k
' Optional: Go to the top of the document to view the list
doc.GoTo What:=wdGoToPage, Which:=wdGoToFirst
MsgBox "Questions extracted and consolidated with full-text hyperlinks, and original questions are now hyperlinked to the top list.", vbInformation, "Process Complete"
End Sub
No comments:
Post a Comment