VBA Excel - Add Picture from a folder into Excel sheet header

PageSetup object (Excel)Represents the page setup description.The PageSetup object contains all page setup attributes (left margin, bottom margin, paper size, and so on) as properties. The following example adds a picture titled Sample.jpg from the C:\ drive to the left section of the header. This example assumes that a file called Sample.jpg exists on the C:\ drive.

Sub InsertPicture()

    With ActiveSheet.PageSetup.CentertFooterPicture
        .FileName = "C:\Sample.jpg"
        .Height = 275.25
        .Width = 463.5
        .Brightness = 0.36
        .ColorType = msoPictureGrayscale
        .Contrast = 0.39
        .CropBottom = -14.4
        .CropLeft = -28.8
        .CropRight = -14.4
        .CropTop = 21.6
    End With

    ' Enable the image to show up in the left header. 
    ActiveSheet.PageSetup.LeftHeader = "&G"
    ' Enable the image to show up in the center footer. 
    ActiveSheet.PageSetup.CenterFooter = "&G"

End Sub

VBA Word - Convert Multiple HTML pages into Markdown, MD files

Run the following VBA Excel program. The program opens chat.html file from source folder in default browser. Then it selects all its content and paste into a text file. The text file is named the folder name with file extension .md and saved into the parent folder. This process is repeated for all subfolders of the parent folder.

Private Sub ConvertChatHtmlToMarkdown_NoWarnings(sourceFolder As String)
    Dim fso As Object
    Dim chatFilePath As String
    Dim parentFolder As String
    Dim folderName As String
    Dim markdownFilePath As String
    Dim htmlContent As String
    Dim ts As Object
    Dim shellCommand As String

    ' Ensure sourceFolder ends without trailing backslash
    If Right(sourceFolder, 1) = "\" Then
        sourceFolder = Left(sourceFolder, Len(sourceFolder) - 1)
    End If

    chatFilePath = sourceFolder & "\chat.html"

    ' Check if chat.html exists
    If Dir(chatFilePath) = "" Then
        Debug.Print "chat.html not found in: " & sourceFolder
        Exit Sub
    End If

    ' Open chat.html in default browser silently without FollowHyperlink
    shellCommand = "cmd /c start """" """ & chatFilePath & """"
    Shell shellCommand, vbHide

    ' Create FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")

    ' Read HTML content
    Set ts = fso.OpenTextFile(chatFilePath, 1, False, -2)
    htmlContent = ts.ReadAll
    ts.Close

    ' Get folder and parent folder names
    folderName = fso.GetFolder(sourceFolder).Name
    parentFolder = fso.GetFolder(sourceFolder).parentFolder.Path
    markdownFilePath = parentFolder & "\" & folderName & ".md"

    ' Write to .md file
    Set ts = fso.CreateTextFile(markdownFilePath, True, True)
    ts.Write htmlContent
    ts.Close

    Debug.Print "Converted: " & folderName & " -> " & markdownFilePath
End Sub

Sub ProcessAllChats()
    Dim fso As Object
    Dim sourceFolderPath As String
    Dim sourceFolder As Object
    Dim subfolder As Object

    Set fso = CreateObject("Scripting.FileSystemObject")

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Root Folder Containing Chat Folders"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub ' User cancelled
        sourceFolderPath = .SelectedItems.Item(1)
    End With

    Set sourceFolder = fso.GetFolder(sourceFolderPath)

    For Each subfolder In sourceFolder.SubFolders
        ConvertChatHtmlToMarkdown_NoWarnings subfolder.Path
    Next

    MsgBox "All chat.html files processed.", vbInformation
End Sub

VBA Word - Convert HTML content into a Markdown (MD) file

Run the following VBA Excel program. The program opens chat.html file from source folder in your default browser (e.g. Chrome). Then it selects all its content and paste into a text file. The text file is named the source folder name with file extension .md  and saved into the parent folder.

Sub ConvertChatHtmlToMarkdown()
    Dim fso As Object
    Dim sourceFolder As String
    Dim chatFilePath As String
    Dim parentFolder As String
    Dim folderName As String
    Dim markdownFilePath As String
    Dim htmlContent As String
    Dim ts As Object
    Dim fileContent As String

    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count <> 1 Then Exit Sub
        sourceFolder = .SelectedItems.Item(1)
    End With


    ' Build full path to chat.html
    chatFilePath = sourceFolder & "\chat.html"

    ' Check if chat.html exists
    If Dir(chatFilePath) = "" Then
        MsgBox "chat.html not found in " & sourceFolder, vbExclamation
        Exit Sub
    End If

    ' Open chat.html in default browser
    ThisWorkbook.FollowHyperlink chatFilePath

    ' Read the HTML file content
    Set ts = fso.OpenTextFile(chatFilePath, 1, False, -2) ' -2 means Unicode/AutoDetect
    htmlContent = ts.ReadAll
    ts.Close

    ' Get folder name and parent folder path
    folderName = fso.GetFolder(sourceFolder).Name
    parentFolder = fso.GetFolder(sourceFolder).parentFolder.Path

    ' Build output .md file path
    markdownFilePath = parentFolder & "\" & folderName & ".md"

    ' Write HTML content to .md file
    Set ts = fso.CreateTextFile(markdownFilePath, True, True) ' Overwrite, Unicode
    ts.Write htmlContent
    ts.Close

    MsgBox "Markdown file created at:" & vbCrLf & markdownFilePath, vbInformation
End Sub

VBA Word - Convert each Markdown (MD file into HTML

Install Pandoc (free, command-line tool) to run this VBA code to convert each Markdown (MD file into HTML.

Sub ConvertAllMdToHtml()
    Dim fso As Object
    Dim folderPath As String
    Dim file As Object
    Dim mdFilePath As String
    Dim htmlFilePath As String
    Dim command As String

    Set fso = CreateObject("Scripting.FileSystemObject")

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder Containing .md Files"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        folderPath = .SelectedItems.Item(1)
    End With

    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

    For Each file In fso.GetFolder(folderPath).Files
        If LCase(fso.GetExtensionName(file.Name)) = "md" Then
            mdFilePath = file.Path
            htmlFilePath = fso.GetParentFolderName(mdFilePath) & "\" & fso.GetBaseName(mdFilePath) & ".html"
            ' Build Pandoc command
            command = "cmd /c pandoc """ & mdFilePath & """ -f markdown -t html -s -o """ & htmlFilePath & """"
            Shell command, vbHide
        End If
    Next

    MsgBox "All .md files converted to HTML!", vbInformation
End Sub

VBA Word - Delete All Horizontal Lines from a Word document

Use the following VBA code to delete All Horizontal Lines from a Word document:

Sub DeleteAllHorizontalLines()

    Dim oPara As Paragraph
    Dim oShape As InlineShape
    
    ' --- PART 1: Remove Horizontal Lines that are Paragraph Borders ---
    ' Loop through every paragraph in the main document story
    For Each oPara In ActiveDocument.StoryRanges(wdMainTextStory).Paragraphs
        ' Set the bottom border style to "None"
        oPara.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
    Next oPara
    
    ' --- PART 2: Delete Horizontal Line Shapes (Drawings/Graphics) ---
    ' Loop through all Inline Shapes in the main document story
    ' We loop backwards in case multiple shapes are deleted in a row
    Dim i As Long
    For i = ActiveDocument.InlineShapes.Count To 1 Step -1
        Set oShape = ActiveDocument.InlineShapes(i)
        
        ' Check if the shape is a dedicated horizontal line object
        If oShape.Type = wdInlineShapeHorizontalLine Then
            oShape.Delete
        End If
    Next i

    MsgBox "All common horizontal lines have been removed!", vbInformation

End Sub

VBA Word - Customize Table Width in Microsoft Word

Use the following VBA code to set width of each table in your Microsoft Word document:

Sub TableGridDesignMacro()

   For Each Table In ActiveDocument.Tables
    Table.Style = "Table Grid"	
    Table.PreferredWidthType = wdPreferredWidthPoints
    Table.PreferredWidth = InchesToPoints(6.67)
   Next

End Sub

VBA Word Resize all images of document proportionately

VBA Word code which resizes all images of the document proportionately so that they all fit inside the document. You can keep width of images 80% or some other percentage of width of the document width.

Sub ResizeAllImages()
    Dim shp As InlineShape
    Dim fshp As Shape
    Dim doc As Document
    Dim pageWidth As Single
    Dim marginWidth As Single
    Dim usableWidth As Single
    Dim targetWidth As Single
    
    Set doc = ActiveDocument
    
    ' Calculate usable width (page width minus left and right margins)
    pageWidth = doc.PageSetup.PageWidth
    marginWidth = doc.PageSetup.LeftMargin + doc.PageSetup.RightMargin
    usableWidth = pageWidth - marginWidth
    
    ' Set target width = 80% of usable width
    targetWidth = usableWidth * 0.8
    
    ' Loop through inline shapes (images inside text)
    For Each shp In doc.InlineShapes
        If shp.Type = wdInlineShapePicture Or shp.Type = wdInlineShapeLinkedPicture Or shp.Type = wdInlineShapeEmbeddedOLEObject Then
            ' Resize proportionally
            shp.LockAspectRatio = msoTrue
            If shp.Width > targetWidth Then
                shp.Width = targetWidth
            End If
        End If
    Next shp
    
    ' Loop through floating shapes (images not inline)
    For Each fshp In doc.Shapes
        If fshp.Type = msoPicture Or fshp.Type = msoLinkedPicture Then
            ' Resize proportionally
            fshp.LockAspectRatio = msoTrue
            If fshp.Width > targetWidth Then
                fshp.Width = targetWidth
            End If
        End If
    Next fshp
    
    MsgBox "All images resized to max width = 80% of document width.", vbInformation
End Sub

VBA Word Extract and Reverse Blocks of paragraphs in Word document

Extract and Reverse "Prompted" Blocks in Word using VBA Macro

🧩 What This Macro Does

This VBA macro is designed for Microsoft Word documents that contain multiple occurrences of a keyword such as "Prompted". It automatically:

1. Searches from bottom to top of the document.

2. Each time it finds a line containing the word "Prompted", it:

   • Selects from that line to the end of the document,

   • Cuts the block,

   • Pastes it at the end of a new document.

3. This process continues until no more "Prompted" entries are found.

4. The result is a new Word document with all such blocks extracted in reversed order (i.e., last occurrence first).

5. The new document is saved:

   • In the same folder as the source file,

   • With a timestamped filename like:
     OriginalName_reversed_20250806_162530.docx

6. Finally, the original document is closed without saving any changes, keeping your source document untouched.

---

⚙️ Use Case Examples

• Reorganizing structured logs or notes in reverse or Gemini Chats copied in MS-Word

• Extracting repeated section-based content like surveys or prompted responses.

• Working with very large documents (e.g., 1000+ pages) efficiently.

---

🚀 Code

Sub ExtractPromptedBlocks_TrueReverse_SaveTimestamped_CloseOriginal()

    Dim docSource As Document
    Dim docTarget As Document
    Dim rngSearch As Range
    Dim rngCut As Range
    Dim findText As String
    Dim sourcePath As String
    Dim sourceName As String
    Dim savePath As String
    Dim timestamp As String

    ' Reference the active (source) document
    Set docSource = ActiveDocument
    Set docTarget = Documents.Add

    findText = "Prompted"

    ' Start from the end of the document
    Set rngSearch = docSource.Content
    rngSearch.Collapse Direction:=wdCollapseEnd

    ' Loop to cut "Prompted" blocks from bottom to top
    Do
        rngSearch.Find.ClearFormatting
        With rngSearch.Find
            .Text = findText
            .Forward = False
            .MatchCase = False
            .Wrap = wdFindStop
        End With

        If rngSearch.Find.Execute Then
            Set rngCut = docSource.Range(rngSearch.Paragraphs(1).Range.Start, docSource.Content.End)
            rngCut.Cut

            With docTarget.Content
                .Collapse Direction:=wdCollapseEnd
                .Paste
                .InsertParagraphAfter
            End With

            Set rngSearch = docSource.Range(0, rngSearch.Paragraphs(1).Range.Start)
        Else
            Exit Do
        End If
    Loop

    ' Prepare timestamp for unique filename
    timestamp = Format(Now, "_reversed_yyyymmdd_HHmmss")
    
    ' Build full save path
    sourcePath = docSource.Path
    sourceName = Left(docSource.Name, InStrRev(docSource.Name, ".") - 1)
    savePath = sourcePath & Application.PathSeparator & sourceName & timestamp & ".docx"

    ' Save new document with timestamped name
    docTarget.SaveAs2 FileName:=savePath, FileFormat:=wdFormatXMLDocument

    ' Close original document WITHOUT saving
    docSource.Close SaveChanges:=wdDoNotSaveChanges

    MsgBox "Done! Reversed content saved as:" & vbCrLf & savePath, vbInformation

End Sub

---

🚀 Benefits

• Fully automated and repeatable

• Works even with massive documents

• Prevents accidental overwrites using timestamped filenames

• Non-destructive to the original document

---

🧠 To Use the Macro

1. Open the Word document.

2. Press Alt + F11 to open the VBA Editor.

3. Insert a new module and paste the macro code.

4. Run the macro using Alt + F8.

---

This macro saves hours of manual effort and ensures accurate, clean extraction of structured content in reverse order. Ideal for professionals working with large, templated Word documents.

---

VBA Word Insert Custom Page Numbers and Remove Spelling & Grammar Errors from multiple documents

The spelling and grammar errors are disabled and in the bottom RHS pagination is done which is of style: Page X of Y. X stands for current page number and Y for total page count in the document.

Sub ProcessWordDocuments()
    ' Main subroutine to iterate through Word documents in a specified folder
    ' and apply formatting (hide errors, insert custom page numbers).

    Dim sPath As String         ' Declares a string variable to hold the folder path.
    Dim sFile As String         ' Declares a string variable to hold the current file name.
    Dim doc As Word.Document    ' Declares an object variable to represent an opened Word document.

    ' --- Configuration ---
    ' Set the path to the folder containing your Word documents.
    ' Ensure a trailing backslash for correct path concatenation.
    sPath = "D:\Words\"

    ' --- Folder Existence Check ---
    ' Verify if the specified folder exists before proceeding.
    If Dir(sPath, vbDirectory) = "" Then
        MsgBox "The specified folder does not exist: " & sPath, vbExclamation
        Exit Sub ' Exit the subroutine if the folder is not found.
    End If

    ' --- Performance Optimization ---
    ' Turn off screen updating to speed up the process and prevent screen flickering.
    ' This makes the macro run much faster, especially with many documents.
    Application.ScreenUpdating = False

    ' --- File Iteration Loop ---
    ' Find the first Word document in the specified folder.
    ' "*.doc?" matches both .doc (Word 97-2003) and .docx (Word 2007+) files.
    sFile = Dir(sPath & "*.doc?")
    ThisDocument.ActiveWindow.Visible = False
    ' Loop through all found Word documents until no more files are found (sFile becomes "").
    Do While sFile <> ""
        ' --- Error Handling for Current Document ---
        ' Enable error handling for the current iteration. If an error occurs,
        ' the code jumps to the 'ErrorHandler' label.
        On Error GoTo ErrorHandler

        ' --- Open Document ---
        ' Open the current document.
        Set doc = Documents.Open(FileName:=sPath & sFile)
        doc.ActiveWindow.Visible = False
        ' --- Apply Formatting: Hide Spelling and Grammatical Errors ---
        ' Set document properties to hide wavy underlines for errors.
        doc.ShowGrammaticalErrors = False
        doc.ShowSpellingErrors = False

        ' --- Call Helper Subroutine: Insert Custom Page Numbers ---
        ' Call the private helper subroutine to insert the desired page numbering format.
        Call InsertCustomPageNumbers(doc)

        ' --- Save and Close Document ---
        ' Save changes made to the document.
        doc.Save
        ' Close the document without prompting to save changes again (as it was just saved).
        doc.Close SaveChanges:=False

        ' --- Get Next File ---
        ' Get the next Word document in the folder.
        sFile = Dir ' No arguments mean it continues from the previous Dir search.
    Loop

    ' --- Completion Message ---
    ' Display a message box indicating that all documents have been processed successfully.
    MsgBox "All Word documents in '" & sPath & "' have been processed.", vbInformation
    GoTo CleanExit ' Jump to the clean exit section.

' --- Error Handler ---
ErrorHandler:
    ' Display an error message if an error occurs during processing a document.
    MsgBox "An error occurred while processing '" & sFile & "': " & Err.Description, vbCritical

    ' Attempt to gracefully close the document if it was opened.
    If Not doc Is Nothing Then
        ' If the document had unsaved changes before the error, close without saving them.
        If doc.Saved = False Then
            doc.Close SaveChanges:=wdDoNotSaveChanges
        Else
            ' If it was already saved or no changes were made, just close it.
            doc.Close
        End If
    End If
    ' Resume execution at the line immediately following the error.
    ' This allows the loop to continue processing other files.
    Resume Next

' --- Clean Exit ---
CleanExit:
    ' Turn screen updating back on after the macro finishes.
    Application.ScreenUpdating = True
    ThisDocument.ActiveWindow.Visible = True
End Sub


Private Sub InsertCustomPageNumbers(doc As Word.Document)
    ' This private helper subroutine inserts custom page numbers in the format "Page X of Y"
    ' into the primary footer of each section in the given document.

    Dim sec As Section          ' Declares an object variable for each section in the document.
    Dim footerRange As Word.Range ' Declares a Range object to manipulate footer content.

    ' Loop through each section of the document.
    ' Documents can have multiple sections, each with its own headers/footers.
    For Each sec In doc.Sections
        ' Work with the primary footer of the current section.
        With sec.Footers(wdHeaderFooterPrimary)
            ' --- Clear Existing Footer Content ---
            ' Delete all existing content within the footer range to ensure a clean overwrite.
            .Range.Delete

            ' --- Prepare Footer Range for Insertion ---
            ' Get a fresh range object representing the (now empty) footer.
            Set footerRange = .Range
            ' Collapse the range to a single insertion point at the very end of the footer.
            ' This is crucial for building the content backwards from right to left.
            footerRange.Collapse Direction:=wdCollapseEnd
            ' Align the paragraph containing the page number to the right.
            footerRange.ParagraphFormat.Alignment = wdAlignParagraphRight

            ' --- Insert Total Pages Field (Y) ---
            ' Insert the field that displays the total number of pages in the document.
            footerRange.Fields.Add Range:=footerRange, Type:=wdFieldNumPages
            ' Collapse the range to a single point *before* the just-inserted field.
            ' This prepares for inserting the " of " text to its left.
            footerRange.Collapse Direction:=wdCollapseStart

            ' --- Insert " of " Text ---
            ' Insert the literal text " of " to the left of the total pages field.
            footerRange.InsertBefore " of "
            ' Collapse the range to a single point *before* the just-inserted " of " text.
            ' This prepares for inserting the current page number.
            footerRange.Collapse Direction:=wdCollapseStart

            ' --- Insert Current Page Number Field (X) ---
            ' Insert the field that displays the current page number.
            footerRange.Fields.Add Range:=footerRange, Type:=wdFieldPage
            ' Collapse the range to a single point *before* the just-inserted current page field.
            ' This prepares for inserting the "Page " text.
            footerRange.Collapse Direction:=wdCollapseStart

            ' --- Insert "Page " Text ---
            ' Insert the literal text "Page " to the left of the current page number.
            footerRange.InsertBefore "Page "
            ' No need to collapse after this, as it's the first element.

            ' --- Apply Font Formatting ---
            ' Apply bold, font name (Calibri), and font size (11) to the entire footer's content.
            With .Range.Font
                .Bold = True
                .Name = "Calibri"
                .Size = 11
            End With
        End With
    Next sec

    ' --- Update Fields ---
    ' After all insertions in all sections, update all fields in the document.
    ' This ensures that the page numbers and total page counts are accurately calculated and displayed.
    doc.Fields.Update
End Sub

VBA Word Extract Questions And Move To Top Using Dictionary Two Way Hyperlinks

VBA Word Extract Questions And Move To Top Using Dictionary Two Way Hyperlinks: 

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

VBA Word Bold and Blue the Previous paragraph of ChatGPT

In MS-Word document, to bold and blue color a paragraph if its next paragraph contains just one word ChatGPT. The condition is ChatGPT be the only word on a line.

Sub FormatPreviousParagraphBasedOnFind()

    Dim rng As Word.Range
    Dim found As Boolean

    ' Set the initial range to search in the entire document
    Set rng = ActiveDocument.Content
    found = True ' Initialize to true to enter the loop

    Do While found
        ' Reset find parameters for each iteration
        With rng.Find
            .ClearFormatting
            .Text = "ChatGPT" & Chr(13) ' Search for "ChatGPT" followed by a paragraph mark
            .Forward = True
            .Wrap = wdFindStop ' Stop at the end of the document
            .Format = False
            .MatchCase = True ' Case-sensitive match
            .MatchWholeWord = True ' Ensure it's the whole word
            .MatchWildcards = False
            .MatchFuzzy = False
            .MatchAllWordForms = False
        End With

        ' Execute the find operation
        found = rng.Find.Execute

        ' If "ChatGPT" is found and it's not the very first paragraph
        If found And Not rng.Paragraphs(1).Previous Is Nothing Then
            ' Get the previous paragraph
            Dim prevPara As Paragraph
            Set prevPara = rng.Paragraphs(1).Previous

            ' Apply bold and blue color to the previous paragraph
            With prevPara.Range.Font
                .Bold = True
                .Color = wdColorBlue
            End With

            ' Collapse the range to just after the found "ChatGPT" to continue searching from there
            rng.Collapse Direction:=wdCollapseEnd
        ElseIf found And rng.Paragraphs(1).Previous Is Nothing Then
            ' If "ChatGPT" is found in the first paragraph, there's no previous paragraph to format.
            ' Collapse the range to continue searching.
            rng.Collapse Direction:=wdCollapseEnd
        End If

        ' Important: Reset the range to the remainder of the document for the next search
        ' If not done, the search will keep finding the same instance of "ChatGPT"
        If rng.End >= ActiveDocument.Content.End Then
            found = False ' Stop if we've reached the end of the document
        End If

    Loop

    MsgBox "Formatting complete!", vbInformation

End Sub

VBA Dir function to process multiple Word documents and create Custom Page Numbering

The VBA Dir function is a powerful, built-in function used for interacting with the file system. Here's a concise summary of its main functions:

Finding the First Matching File/Folder:

• When called with a pathname argument (which can include wildcards like * for multiple characters and ? for single characters), Dir returns the name of the first file or folder that matches the specified pattern.
• Example: Dir("C:\MyFolder\*.txt") will return the name of the first .txt file found in C:\MyFolder.

Iterating Through Matching Files/Folders:

• After the initial call with a pathname, subsequent calls to Dir without any arguments (Dir) will return the name of the next file or folder that matches the original pattern and path.
• This allows you to easily loop through all files in a directory that meet certain criteria, as demonstrated in your improved code.

Checking for Existence:

• If Dir does not find any file or folder matching the specified pattern, it returns a zero-length string (""). This makes it a common and efficient way to check if a file or folder exists.
• Example: If Dir("C:\MyFile.txt") <> "" Then MsgBox "File exists"

Specifying Attributes:

The optional attributes argument allows you to filter results based on file attributes (e.g., hidden files, system files, directories). You can combine these attributes using addition.

Common attributes:

• vbNormal (0): Normal files (default if omitted)
• vbReadOnly (1): Read-only files
• vbHidden (2): Hidden files
• vbSystem (4): System files
• vbVolume (8): Volume label (if specified, others are ignored)
• vbDirectory (16): Directories or folders

Example: Dir("C:\*", vbDirectory) will return the name of the first directory in C:\.

In essence, Dir is your go-to function in VBA for:

1. Discovering files and folders based on patterns.
2. Looping through collections of files/folders.
3. Verifying the existence of specific files or folders.

VBA Code to process multiple Word documents:

The following code processes each Word document which is inside D:\Words folder. The spelling and grammar errors are disabled and in the bottom RHS pagination is done which is of style: Page X of Y. X stands for current page number and Y for total page count in the document.

Sub ProcessWordDocuments()
    Dim sPath As String
    Dim sFile As String
    Dim doc As Word.Document

    sPath = "D:\Words\"

    If Dir(sPath, vbDirectory) = "" Then
        MsgBox "The specified folder does not exist: " & sPath, vbExclamation
        Exit Sub
    End If

    Application.ScreenUpdating = False

    sFile = Dir(sPath & "*.doc?")

    Do While sFile <> ""
        On Error GoTo ErrorHandler

        Set doc = Documents.Open(FileName:=sPath & sFile)

        doc.ShowGrammaticalErrors = False
        doc.ShowSpellingErrors = False

        Call InsertCustomPageNumbers(doc)

        doc.Save
        doc.Close SaveChanges:=False

        sFile = Dir
    Loop

    MsgBox "All Word documents in '" & sPath & "' have been processed.", vbInformation
    GoTo CleanExit

ErrorHandler:
    MsgBox "An error occurred while processing '" & sFile & "': " & Err.Description, vbCritical
    If Not doc Is Nothing Then
        If doc.Saved = False Then
            doc.Close SaveChanges:=wdDoNotSaveChanges
        Else
            doc.Close
        End If
    End If
    Resume Next

CleanExit:
    Application.ScreenUpdating = True
End Sub


Private Sub InsertCustomPageNumbers(doc As Word.Document)
    Dim sec As Section
    Dim footerRange As Word.Range

    For Each sec In doc.Sections
        With sec.Footers(wdHeaderFooterPrimary)
            .Range.Delete

            Set footerRange = .Range
            footerRange.Collapse Direction:=wdCollapseEnd ' Start at the end
            footerRange.ParagraphFormat.Alignment = wdAlignParagraphRight

            ' Insert total pages field (Y)
            footerRange.Fields.Add Range:=footerRange, Type:=wdFieldNumPages
            footerRange.Collapse Direction:=wdCollapseStart ' Collapse to before the just inserted field

            ' Insert " of "
            footerRange.InsertBefore " of "
            footerRange.Collapse Direction:=wdCollapseStart

            ' Insert current page number field (X)
            footerRange.Fields.Add Range:=footerRange, Type:=wdFieldPage
            footerRange.Collapse Direction:=wdCollapseStart

            ' Insert "Page "
            footerRange.InsertBefore "Page "
            
            With .Range.Font
                .Bold = True
                .Name = "Calibri"
                .Size = 11
            End With
        End With
    Next sec

    doc.Fields.Update
End Sub

VBA Code with detailed comments

Sub ProcessWordDocuments()
    ' Main subroutine to iterate through Word documents in a specified folder
    ' and apply formatting (hide errors, insert custom page numbers).

    Dim sPath As String         ' Declares a string variable to hold the folder path.
    Dim sFile As String         ' Declares a string variable to hold the current file name.
    Dim doc As Word.Document    ' Declares an object variable to represent an opened Word document.

    ' --- Configuration ---
    ' Set the path to the folder containing your Word documents.
    ' Ensure a trailing backslash for correct path concatenation.
    sPath = "D:\Words\"

    ' --- Folder Existence Check ---
    ' Verify if the specified folder exists before proceeding.
    If Dir(sPath, vbDirectory) = "" Then
        MsgBox "The specified folder does not exist: " & sPath, vbExclamation
        Exit Sub ' Exit the subroutine if the folder is not found.
    End If

    ' --- Performance Optimization ---
    ' Turn off screen updating to speed up the process and prevent screen flickering.
    ' This makes the macro run much faster, especially with many documents.
    Application.ScreenUpdating = False

    ' --- File Iteration Loop ---
    ' Find the first Word document in the specified folder.
    ' "*.doc?" matches both .doc (Word 97-2003) and .docx (Word 2007+) files.
    sFile = Dir(sPath & "*.doc?")

    ' Loop through all found Word documents until no more files are found (sFile becomes "").
    Do While sFile <> ""
        ' --- Error Handling for Current Document ---
        ' Enable error handling for the current iteration. If an error occurs,
        ' the code jumps to the 'ErrorHandler' label.
        On Error GoTo ErrorHandler

        ' --- Open Document ---
        ' Open the current document.
        Set doc = Documents.Open(FileName:=sPath & sFile)

        ' --- Apply Formatting: Hide Spelling and Grammatical Errors ---
        ' Set document properties to hide wavy underlines for errors.
        doc.ShowGrammaticalErrors = False
        doc.ShowSpellingErrors = False

        ' --- Call Helper Subroutine: Insert Custom Page Numbers ---
        ' Call the private helper subroutine to insert the desired page numbering format.
        Call InsertCustomPageNumbers(doc)

        ' --- Save and Close Document ---
        ' Save changes made to the document.
        doc.Save
        ' Close the document without prompting to save changes again (as it was just saved).
        doc.Close SaveChanges:=False

        ' --- Get Next File ---
        ' Get the next Word document in the folder.
        sFile = Dir ' No arguments mean it continues from the previous Dir search.
    Loop

    ' --- Completion Message ---
    ' Display a message box indicating that all documents have been processed successfully.
    MsgBox "All Word documents in '" & sPath & "' have been processed.", vbInformation
    GoTo CleanExit ' Jump to the clean exit section.

' --- Error Handler ---
ErrorHandler:
    ' Display an error message if an error occurs during processing a document.
    MsgBox "An error occurred while processing '" & sFile & "': " & Err.Description, vbCritical

    ' Attempt to gracefully close the document if it was opened.
    If Not doc Is Nothing Then
        ' If the document had unsaved changes before the error, close without saving them.
        If doc.Saved = False Then
            doc.Close SaveChanges:=wdDoNotSaveChanges
        Else
            ' If it was already saved or no changes were made, just close it.
            doc.Close
        End If
    End If
    ' Resume execution at the line immediately following the error.
    ' This allows the loop to continue processing other files.
    Resume Next

' --- Clean Exit ---
CleanExit:
    ' Turn screen updating back on after the macro finishes.
    Application.ScreenUpdating = True
End Sub


Private Sub InsertCustomPageNumbers(doc As Word.Document)
    ' This private helper subroutine inserts custom page numbers in the format "Page X of Y"
    ' into the primary footer of each section in the given document.

    Dim sec As Section          ' Declares an object variable for each section in the document.
    Dim footerRange As Word.Range ' Declares a Range object to manipulate footer content.

    ' Loop through each section of the document.
    ' Documents can have multiple sections, each with its own headers/footers.
    For Each sec In doc.Sections
        ' Work with the primary footer of the current section.
        With sec.Footers(wdHeaderFooterPrimary)
            ' --- Clear Existing Footer Content ---
            ' Delete all existing content within the footer range to ensure a clean overwrite.
            .Range.Delete

            ' --- Prepare Footer Range for Insertion ---
            ' Get a fresh range object representing the (now empty) footer.
            Set footerRange = .Range
            ' Collapse the range to a single insertion point at the very end of the footer.
            ' This is crucial for building the content backwards from right to left.
            footerRange.Collapse Direction:=wdCollapseEnd
            ' Align the paragraph containing the page number to the right.
            footerRange.ParagraphFormat.Alignment = wdAlignParagraphRight

            ' --- Insert Total Pages Field (Y) ---
            ' Insert the field that displays the total number of pages in the document.
            footerRange.Fields.Add Range:=footerRange, Type:=wdFieldNumPages
            ' Collapse the range to a single point *before* the just-inserted field.
            ' This prepares for inserting the " of " text to its left.
            footerRange.Collapse Direction:=wdCollapseStart

            ' --- Insert " of " Text ---
            ' Insert the literal text " of " to the left of the total pages field.
            footerRange.InsertBefore " of "
            ' Collapse the range to a single point *before* the just-inserted " of " text.
            ' This prepares for inserting the current page number.
            footerRange.Collapse Direction:=wdCollapseStart

            ' --- Insert Current Page Number Field (X) ---
            ' Insert the field that displays the current page number.
            footerRange.Fields.Add Range:=footerRange, Type:=wdFieldPage
            ' Collapse the range to a single point *before* the just-inserted current page field.
            ' This prepares for inserting the "Page " text.
            footerRange.Collapse Direction:=wdCollapseStart

            ' --- Insert "Page " Text ---
            ' Insert the literal text "Page " to the left of the current page number.
            footerRange.InsertBefore "Page "
            ' No need to collapse after this, as it's the first element.

            ' --- Apply Font Formatting ---
            ' Apply bold, font name (Calibri), and font size (11) to the entire footer's content.
            With .Range.Font
                .Bold = True
                .Name = "Calibri"
                .Size = 11
            End With
        End With
    Next sec

    ' --- Update Fields ---
    ' After all insertions in all sections, update all fields in the document.
    ' This ensures that the page numbers and total page counts are accurately calculated and displayed.
    doc.Fields.Update
End Sub

VBA Replace lines which contains date in specific format with specific text

VBA code to replace all rows from a text file which contains date format like Jan 09, 2025 with text ANSWER. The code should also check if line begins with single tab before the date.

Sub ReplaceLinesWithSpecificDateFormat()
    Dim fso As Object
    Dim inputFile As Object
    Dim outputFile As Object
    Dim filePath As String
    Dim tempPath As String
    Dim line As String
    Dim regex As Object

    ' Change this to your actual file path
    filePath = "C:\Path\To\Your\File.txt"
    tempPath = filePath & ".tmp"

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set inputFile = fso.OpenTextFile(filePath, 1) ' ForReading
    Set outputFile = fso.CreateTextFile(tempPath, True) ' Overwrite

    ' Create RegExp to match lines starting with tab and a date like May 09, 2025
    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .Pattern = "^\t(January|February|March|April|May|June|July|August|September|October|November|December) \d{2}, \d{4}"
        .IgnoreCase = True
        .Global = False
    End With

    ' Read each line and write to temp file, replacing matching lines with "ANSWER"
    Do Until inputFile.AtEndOfStream
        line = inputFile.ReadLine
        If regex.Test(line) Then
            outputFile.WriteLine "ANSWER"
        Else
            outputFile.WriteLine line
        End If
    Loop

    inputFile.Close
    outputFile.Close

    ' Replace original file with modified content
    fso.DeleteFile filePath
    fso.MoveFile tempPath, filePath

    MsgBox "Matching lines replaced with 'ANSWER'!", vbInformation
End Sub

VBA Delete lines which contains date in specific format

VBA code to delete all rows from a text file which contains date format like Jan 09, 2025. The code should also check if line begins with single tab before the date.

Sub DeleteLinesWithSpecificDateFormat()
    Dim fso As Object
    Dim inputFile As Object
    Dim outputFile As Object
    Dim filePath As String
    Dim tempPath As String
    Dim line As String
    Dim regex As Object

    ' Change this to your actual file path
    filePath = "C:\Users\ajeet\Desktop\meta\meta.txt"
    tempPath = filePath & ".tmp"

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set inputFile = fso.OpenTextFile(filePath, 1) ' ForReading
    Set outputFile = fso.CreateTextFile(tempPath, True) ' Overwrite

    ' Create RegExp to match lines starting with tab and a date like May 09, 2025
    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .Pattern = "^\t(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) \d{2}, \d{4}"
        .IgnoreCase = True
        .Global = False
    End With

    ' Read each line and write to temp file if it doesn't match
    Do Until inputFile.AtEndOfStream
        line = inputFile.ReadLine
        If Not regex.Test(line) Then
            outputFile.WriteLine line
        End If
    Loop

    inputFile.Close
    outputFile.Close

    ' Replace original file with filtered content
    fso.DeleteFile filePath
    fso.MoveFile tempPath, filePath

    MsgBox "Lines removed successfully!", vbInformation
End Sub

VBA Word - Convert Pipe Tables To Word Tables Latest

Sub ConvertPipeTablesToWordTables()
    Dim doc As Document
    Set doc = ActiveDocument

    Dim rngFind As Range
    Set rngFind = doc.Content.Duplicate

    Dim tableDict As Scripting.Dictionary
    Set tableDict = New Scripting.Dictionary

    Dim rowCounter As Long
    rowCounter = 1

    With rngFind.Find
        .Text = "|--"
        .Forward = True
        .Wrap = wdFindStop
        .MatchWildcards = False
    End With

    Do While rngFind.Find.Execute
        Dim anchorPara As Paragraph
        Set anchorPara = rngFind.Paragraphs(1)

        Dim headerPara As Paragraph
        Set headerPara = anchorPara.Previous

        If Not headerPara Is Nothing Then
            If IsValidTableRow(headerPara.Range.Text) Then
                ' Clear existing dictionary for reuse
                tableDict.RemoveAll
                rowCounter = 1

                ' Store header row
                tableDict.Add rowCounter, headerPara.Range.Text
                rowCounter = rowCounter + 1

                ' Prepare range for deleting data lines (excluding anchorPara)
                Dim dataRange As Range
                Set dataRange = Nothing

                ' Collect data rows
                Dim nextPara As Paragraph
                Set nextPara = anchorPara.Next

                Do While Not nextPara Is Nothing
                    If IsValidTableRow(nextPara.Range.Text) Then
                        tableDict.Add rowCounter, nextPara.Range.Text
                        rowCounter = rowCounter + 1

                        If dataRange Is Nothing Then
                            Set dataRange = nextPara.Range.Duplicate
                        Else
                            dataRange.End = nextPara.Range.End
                        End If

                        Set nextPara = nextPara.Next
                    Else
                        Exit Do
                    End If
                Loop

                ' Insert table at header position
                InsertTableFromDictionary tableDict, headerPara.Range

                ' Delete only the data lines (not the anchor)
                If Not dataRange Is Nothing Then dataRange.Delete

                ' Now delete the anchor row separately
                anchorPara.Range.Delete
            End If
        End If

        rngFind.Start = anchorPara.Range.End + 1
        rngFind.End = doc.Content.End
    Loop

    Set tableDict = Nothing
End Sub

Function IsValidTableRow(lineText As String) As Boolean
    Dim trimmed As String
    trimmed = Trim(lineText)

    Dim pipeCount As Long
    pipeCount = UBound(Split(trimmed, "|")) - 1

    IsValidTableRow = (pipeCount >= 2 And InStr(trimmed, "|") > 0)
End Function

Sub InsertTableFromDictionary(dict As Scripting.Dictionary, insertRange As Range)
    If dict.Count = 0 Then Exit Sub

    Dim rowCount As Long: rowCount = dict.Count
    Dim colCount As Long: colCount = UBound(Split(dict.Item(1), "|")) - 1

    Dim tbl As Table
    Set tbl = insertRange.Tables.Add(Range:=insertRange, NumRows:=rowCount, NumColumns:=colCount)
    tbl.Borders.Enable = True

    Dim r As Long, c As Long, i As Long
    For r = 1 To rowCount
        Dim cells() As String
        cells = Split(dict.Item(r), "|")

        c = 1
        For i = 1 To UBound(cells) - 1
            tbl.Cell(r, c).Range.Text = Trim(cells(i))
            c = c + 1
        Next i
    Next r

    ' Bold the first row (header)
    tbl.Rows(1).Range.Bold = True
End Sub

Word VBA - Convert ChatGPT file into Word document

Run subroutines one by one in order:

Sub ChatGptDocumentMaker()
    ClearBgColorGrotic1One
    BoldTextBetweenUserAndChatGPT2Two
    ReplaceUser3Three
    ReplaceGPTbyAnswer4Four
    DoubleParaToSingle5Five
    BoldTextBeforeLastDoubleStars6Six
    BoldAndColorLinesStartingWithTripleHash7Seven
    AdjustTableWidths8Eight
    AdjustImageSizes9Nine
    FormatTripleBacktickSections10Ten
    DeleteLineContainingTripleBackticks11Eleven
End Sub

Run the following code to select document and remove special formatting

Sub ClearBgColorGrotic1One()
    Selection.WholeStory
    Selection.Font.Name = "a_Grotic"
    Selection.Shading.Texture = wdTextureNone
    Selection.Shading.ForegroundPatternColor = wdColorAutomatic
    Selection.Shading.BackgroundPatternColor = wdColorAutomatic
End Sub

Run the following code to Bold Text between user and ChatGPT

Sub BoldTextBetweenUserAndChatGPT2Two()
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Bold = True

    With Selection.Find
        .Text = "user^13(*)ChatGPT^13"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWildcards = True
    End With
    
    With Selection.Find.Replacement.Font
        .Size = 10
        .Bold = True
        .Color = wdColorBlue
        .Name = "Georgia"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Run the following code

Sub ReplaceUser3Three()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    
    With Selection.Find
        .Text = "user^13"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Run the following code:

Sub ReplaceGPTbyAnswer4Four()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 10
        .Bold = False
        .Italic = False
        .Color = wdColorBlack
        .Name = "Courier New"
    End With
    With Selection.Find
        .Text = "ChatGPT^p"
        .Replacement.Text = "Answer: "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Run the following code:

Sub DoubleParaToSingle5Five()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^p^p"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Run the following code:

Sub BoldTextBeforeLastDoubleStars6Six()
    Dim doc As Document
    Dim para As Paragraph
    Dim pos As Integer
    Dim lineText As String
    Dim rng As Range
    Dim lastPos As Integer
    
    ' Set the document
    Set doc = ActiveDocument
    
    ' Loop through each paragraph in the document
    For Each para In doc.Paragraphs
        lineText = para.Range.Text
        lastPos = InStrRev(lineText, "**")
        
        ' If '**' is found, bold the preceding text
        If lastPos > 1 Then
            Set rng = para.Range.Duplicate
            rng.End = rng.Start + lastPos - 1
            rng.Font.Bold = True
        End If
    Next para
End Sub

Run the following code:

Sub BoldAndColorLinesStartingWithTripleHash7Seven()
    Dim doc As Document
    Dim para As Paragraph
    Dim lineText As String
    Dim rng As Range
    Dim pos As Integer
    
    ' Set the document
    Set doc = ActiveDocument
    
    ' Loop through each paragraph in the document
    For Each para In doc.Paragraphs
        lineText = para.Range.Text
        pos = InStr(lineText, "###")
        
        ' If the paragraph starts with '###', format the entire paragraph
        If pos = 1 Then
            Set rng = para.Range
            rng.Font.Bold = True
            rng.Font.Color = wdColorBrown
            rng.Font.Size = 10
        End If
    Next para
End Sub

Run the following code:

Sub AdjustTableWidths8Eight()
    Dim doc As Document
    Dim tbl As Table
    Dim tblWidth As Single
    Dim docWidth As Single

    Set doc = ActiveDocument
    docWidth = doc.PageSetup.PageWidth - doc.PageSetup.LeftMargin - doc.PageSetup.RightMargin

    For Each tbl In doc.Tables
        tblWidth = tbl.PreferredWidth

        If tblWidth > docWidth Then
            tbl.PreferredWidth = docWidth
            tbl.AllowAutoFit = False ' Prevent autofit to ensure width stays as set
            ' Optionally, you can adjust column widths proportionally
            Dim col As Column
            Dim totalColWidth As Single
            totalColWidth = 0

            ' Calculate total width of columns
            For Each col In tbl.Columns
                totalColWidth = totalColWidth + col.Width
            Next col

            ' Adjust each column proportionally
            For Each col In tbl.Columns
                col.Width = col.Width * docWidth / totalColWidth
            Next col
        End If
    Next tbl
End Sub

Run the following code

Sub AdjustImageSizes9Nine()
    Dim doc As Document
    Dim img As InlineShape
    Dim shape As shape
    Dim docWidth As Single

    Set doc = ActiveDocument
    docWidth = doc.PageSetup.PageWidth - doc.PageSetup.LeftMargin - doc.PageSetup.RightMargin

    ' Loop through all inline shapes (embedded images)
    For Each img In doc.InlineShapes
        If img.Width > docWidth Then
            img.LockAspectRatio = msoTrue
            img.Width = docWidth
        End If
    Next img

    ' Loop through all floating shapes (floating images)
    For Each shape In doc.Shapes
        If shape.Type = msoPicture Or shape.Type = msoLinkedPicture Then
            If shape.Width > docWidth Then
                shape.LockAspectRatio = msoTrue
                shape.Width = docWidth
            End If
        End If
    Next shape
End Sub

Run the following code:

Sub FormatTripleBacktickSections10Ten()
    Dim doc As Document
    Dim rng As Range
    Dim startRng As Range
    Dim endRng As Range
    Dim textRng As Range
    Dim found As Boolean
    Dim languages As Variant
    Dim i As Integer

    Set doc = ActiveDocument
    Set rng = doc.Content

    ' Array of languages to check
    languages = Array("```csharp", "```css", "```html", "```javascript", "```sql")

    For i = LBound(languages) To UBound(languages)
        With rng.Find
            .ClearFormatting
            .Text = languages(i) & "^13"

            Do While .Execute(Forward:=True) = True
                ' Set the start range at the end of the found triple backticks line
                Set startRng = rng.Duplicate
                startRng.Collapse Direction:=wdCollapseEnd

                ' Find the closing triple backticks
                With startRng.Find
                    .Text = "```^13"
                    If .Execute(Forward:=True) = True Then
                        ' Set the end range at the start of the found triple backticks line
                        Set endRng = startRng.Duplicate
                        endRng.Collapse Direction:=wdCollapseStart

                        ' Set the text range between the end of the starting triple backticks and the start of the ending triple backticks
                        Set textRng = doc.Range(rng.End, startRng.Start - 1)

                        ' Apply single line spacing, before spacing 5pt, and after spacing 5pt
                        With textRng.ParagraphFormat
                            .SpaceBefore = 5
                            .SpaceAfter = 5
                            .LineSpacingRule = wdLineSpaceSingle
                        End With

                        ' Apply font style and color
                        With textRng.Font
                            .Name = "Calibri" ' or "Arial Narrow"
                            .Size = 9 ' Adjust the font size as needed
                        End With

                        ' Fill the background color with a very light cyan
                        textRng.Shading.BackgroundPatternColor = RGB(204, 255, 255) ' Light cyan

                    End If
                End With

                ' Move the main search range past the found end triple backticks
                rng.Start = startRng.End
            Loop
        End With

        ' Reset the range for the next language search
        Set rng = doc.Content
    Next i
End Sub

Run the following code

Sub DeleteLineContainingTripleBackticks11Eleven()
    Dim doc As Document
    Dim rng As Range
    Dim findText As String
    
    ' The text to search for: any word starting with ```
    findText = "```"
    
    Set doc = ActiveDocument
    Set rng = doc.Content
    
    With rng.Find
        .ClearFormatting
        .Text = findText
        .Forward = True
        .Wrap = wdFindStop
        
        Do While .Execute
            ' Move range to the start of the line containing the found text
            rng.Start = rng.Paragraphs(1).Range.Start
            ' Extend range to the end of the line
            rng.End = rng.Paragraphs(1).Range.End
            ' Delete the line
            rng.Delete
            
            ' Move to the next instance
            rng.Collapse Direction:=wdCollapseEnd
        Loop
    End With
End Sub

Run the following code

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

    ' 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) & vbCrLf
        
        ' 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, "Q" & i, questionRangesDict(i)
    Next i
End Sub

Run the following code

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 Sequence ChatGPT Code

This VBA code is used to Sequence my personal ChatGPT Word document.

 ''' Date 2024 July30

 Sub ChatGPT_Sequence()
    ClearAllColorBg1
    BoldTextBetweenUserAndChatGPT2
    ReplaceUser3
    ReplaceGPTbyAnswer4
    DoubleParaToSingle5
    BoldTextBeforeLastDoubleStars
    BoldAndColorLinesStartingWithTripleHash
    MsgBox "Done"
End Sub 

 Sub ClearAllColorBg1()
    Selection.WholeStory
    Selection.Shading.Texture = wdTextureNone
    Selection.Shading.ForegroundPatternColor = wdColorAutomatic
    Selection.Shading.BackgroundPatternColor = wdColorAutomatic
End Sub 

 Sub BoldTextBetweenUserAndChatGPT2()
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Bold = True

    With Selection.Find
        .Text = "user^13(*)ChatGPT^13"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWildcards = True
    End With
    
    With Selection.Find.Replacement.Font
        .Size = 10
        .Bold = True
        .Color = wdColorBlue
        .Name = "Georgia"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub 

 Sub ReplaceUser3()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    
    With Selection.Find
        .Text = "user"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub 

 Sub ReplaceGPTbyAnswer4()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 10
        .Bold = False
        .Italic = False
        .Color = wdColorBlack
        .Name = "Courier New"
    End With
    With Selection.Find
        .Text = "ChatGPT^p"
        .Replacement.Text = "Answer: "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub 

 Sub DoubleParaToSingle5()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^p^p"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub 

 Sub BoldBeforeStarsColon6()
    
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Bold = True
    With Selection.Find
        .Text = "^13[!^13]@\*\*:"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub 

 Sub BoldBeforeColonStars6B()
    
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Bold = True
    With Selection.Find
        .Text = "^13[!^13]@:\*\*"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub 

 Sub BoldBetweenStars7()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Bold = True
    With Selection.Find
        .Text = "\*\*[!^13]@\*\*"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub 

 Sub TripleHash8()

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 10
        .Bold = False
        .Italic = False
        .Color = wdColorBrown
        .Name = "Courier New"
    End With
    
    With Selection.Find
        .Text = "^13###*^13"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub 

 Sub BoldTextBeforeLastDoubleStars()
    Dim doc As Document
    Dim para As Paragraph
    Dim pos As Integer
    Dim lineText As String
    Dim rng As Range
    Dim lastPos As Integer
    
    ' Set the document
    Set doc = ActiveDocument
    
    ' Loop through each paragraph in the document
    For Each para In doc.Paragraphs
        lineText = para.Range.Text
        lastPos = InStrRev(lineText, "**")
        
        ' If '**' is found, bold the preceding text
        If lastPos > 1 Then
            Set rng = para.Range.Duplicate
            rng.End = rng.Start + lastPos - 1
            rng.Font.Bold = True
        End If
    Next para
End Sub 

 Sub BoldAndColorLinesStartingWithTripleHash()
    Dim doc As Document
    Dim para As Paragraph
    Dim lineText As String
    Dim rng As Range
    Dim pos As Integer
    
    ' Set the document
    Set doc = ActiveDocument
    
    ' Loop through each paragraph in the document
    For Each para In doc.Paragraphs
        lineText = para.Range.Text
        pos = InStr(lineText, "###")
        
        ' If the paragraph starts with '###', format the entire paragraph
        If pos = 1 Then
            Set rng = para.Range
            rng.Font.Bold = True
            rng.Font.Color = wdColorBrown
            rng.Font.Size = 11
        End If
    Next para
End Sub 

VBA Word - Process all Word documents of a folder, Delete specific lines

The following VBA code processes all Word documents of a folder one by one. It deletes specific lines which contain some specific texts.

Option Explicit

Sub ProcessFiles()
    Dim FSO As Object
    Dim objFldr As Object
    Dim objFyle As Object
    Dim strFileExtension As String
    Dim appWord As Object
    Dim doc As Object
    
    ' Initialize FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set objFldr = GetFolder()
    
    If objFldr Is Nothing Then Exit Sub ' Exit if no folder is selected

    ' Initialize Word Application
    Set appWord = CreateObject("Word.Application")
    appWord.Visible = True
    
    ' Process each file in the selected folder
    For Each objFyle In objFldr.Files
        strFileExtension = FSO.GetExtensionName(objFyle.Path)
        If LCase(strFileExtension) = "docx" Or LCase(strFileExtension) = "doc" Then
            ' Open the Word document
            Set doc = appWord.Documents.Open(objFyle.Path)
            doc.Activate
            
            ' Apply table style
            Call TableGridDesignMacro
            
            ' Delete specified lines
            Call DeleteLineBeforeAndContainingCopyCode(doc, "You said:")
            Call DeleteLineBeforeAndContainingCopyCode(doc, "Copy code")
            Call DeleteLineBeforeAndContainingCopyCode(doc, "ChatGPT")
            
            ' Save and close the document
            doc.Save
            doc.Close SaveChanges:=True
            Set doc = Nothing
        End If
    Next
    
    ' Quit Word Application
    appWord.Quit
    Set appWord = Nothing
    Set FSO = Nothing
End Sub

Sub DeleteLineBeforeAndContainingCopyCode(doc As Object, strText As String)
    Dim findRange As Range
    Dim deleteRange As Range

    ' Start from the end of the document
    Set findRange = doc.Content
    findRange.Start = findRange.End
    
    ' Search for the text and delete lines
    Do While findRange.Find.Execute(FindText:=strText, Forward:=False, Wrap:=wdFindStop)
        ' Create a range for the current line
        Set deleteRange = findRange.Paragraphs(1).Range
        
        ' Include the line above if it exists
        If deleteRange.Start > doc.Content.Start Then
            deleteRange.Start = deleteRange.Paragraphs(1).Previous.Range.Start
        End If
        
        ' Delete the range
        deleteRange.Delete
    Loop
End Sub

Function GetFolder() As Object
    Dim FSO As Object
    Dim strFolderPath As String
    Dim objFldr As Object

    ' Create a FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    ' Use FileDialog to let the user select a folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count <> 1 Then Exit Function ' Exit if no folder is selected
        strFolderPath = .SelectedItems.Item(1)
    End With
    
    ' Get the selected folder
    Set objFldr = FSO.GetFolder(strFolderPath)
    
    ' Check if the folder contains files
    If objFldr.Files.Count < 1 Then
        MsgBox "No files found in the selected folder.", vbInformation
        Exit Function
    End If
    
    ' Return the folder object
    Set GetFolder = objFldr
    Set FSO = Nothing
End Function

Sub TableGridDesignMacro()
    Dim tbl As Table
    ' Apply "Table Grid" style to all tables in the document
    For Each tbl In ActiveDocument.Tables
        tbl.Style = "Table Grid"
    Next
End Sub

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

The following is new code developed in 2025 which works like before but seems to be better than before.

Sub ExtractQuestionsAndMoveToTopPerfectUsingDictionary_HyperlinkFullText()
    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
    
    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_" or "Q" followed by a number
        If InStr(bm.Name, "Question_") = 1 Or (Left(bm.Name, 1) = "Q" And IsNumeric(Mid(bm.Name, 2, 1))) 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 = "Times New Roman" And .Size = 12 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 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 ---
    ' Your original loop for correct order: Iterate from the last question collected to the first.
    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.
        ' Using "Question_" prefix for clarity and uniqueness.
        targetBookmarkName = "Question_" & k
        
        ' Add a bookmark to the original question's location in the document.
        ' This is the destination for the hyperlink.
        On Error Resume Next ' Resume on error if bookmark somehow already exists
        doc.Bookmarks.Add Name:=targetBookmarkName, Range:=targetQuestionRange
        On Error GoTo 0
        
        ' Prepare the full text that will be displayed as the hyperlink.
        ' This includes "Question N: " prefix + the full question text.
        Dim displayTextForHyperlink As String
        displayTextForHyperlink = "Question " & k & ": " & currentQuestionFullText
        
        ' --- THIS IS THE KEY MODIFICATION ---
        ' Insert the line break *before* the hyperlink text, at the current topRng position.
        ' Your original code used topRng.InsertBefore vbCrLf which works with your loop.
        ' We'll now combine the insertion of the line break and the hyperlink text into one operation.
        
        ' Create a temporary range for inserting the hyperlink and line break at the current
        ' topRng's start. This ensures the correct stacking order.
        Dim insertPoint As Range
        Set insertPoint = doc.Range(topRng.Start, topRng.Start) ' Start of the current topRng
        
        ' Hyperlinks.Add method is used to create a new hyperlink object
        ' and add it to the Hyperlinks collection of a document.
        ' Anchor: required parameter that specifies where in the document the hyperlink will be inserted. It expects a Range object
        ' Address: optional parameter specifies the path and file name of the linked document or the URL for a web page.
        ' SubAddress: optional parameter specifies a sub-location within the linked document.
        ' TextToDisplay: optional parameter specifies the actual text that will be displayed in the document for the hyperlink. This is what the user will see and click on.
        doc.Hyperlinks.Add _
            Anchor:=insertPoint, _
            Address:="", _
            SubAddress:=targetBookmarkName, _
            TextToDisplay:=displayTextForHyperlink

        ' Insert a line break after the hyperlink you just inserted
        insertPoint.InsertAfter vbCrLf
        
        ' Now, crucially, update topRng to encompass the newly inserted content.
        ' This ensures the next iteration's 'insertPoint' is correctly positioned
        ' *before* this content.
        Set topRng = doc.Range(topRng.Start, topRng.End + Len(displayTextForHyperlink) + 2) ' +2 for vbCrLf
        ' This specific recalculation of topRng.End is vital when inserting at the start.
        ' It makes topRng expand to cover what was just added.
        
    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.", vbInformation, "Process Complete"
End Sub

Two way Hyperlinks in Word Document

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 = "Times New Roman" And .Size = 12 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