Excel to Word VBA. Create Hover Texts for 25k Definitions - excel

Question

What is the BEST option to create Hover Texts for 25k Definitions?
(Excel to Word using VBA)
Screen Tips?
Tool Tips?
Foot Notes?
Glossary?
Book Marks?
Other Options?
Over 25K Definitions in Table
Based on feedback and countless HOURS, Im having a tough time figuring out the best option for a Text Hover Effect.
Ive tried Bookmarks and Screen Tips and ran into many issues.
Ive also attempted to tweak the below VBA code to work with Hyperlinks to no avail.
3 STEPS
Select the Term from Column:A
Find the Term in Word Document
ADD Definition From Column:B as a HOVER effect in Word
| Column A | Column B |
| ----------- | ------------------------ |
| Example A | Definition Example.... |
| Example B | Definition Example.... |
Column: A1:A25000 = Term
Column: B1:B25000 = Definition
*The below code works great for finding and highlighting the Terms, But I haven't figured out the Hover Effect.
Favor 2023
`'Version #1: Only loops through Word Document Content for text to Find and Replace.
'Leverage & Lean "Less Clicks, More Results"
Sub FindReplaceAcrossMultipleWordDocumentsFreeMacro()
' Means variable is in use
Dim FindReplaceCounter As Integer '
Dim FolderPath As String '
Dim LastRow As Integer '
Dim LastRowPath As Integer '
Dim MyRange As Object '
Dim oFile As Object '
Dim oFolder As Object '
Dim oFSO As Object '
Dim WordApp As New Word.Application '
Dim WordCounter As Integer '
Dim WordDocument As Object '
On Error GoTo LeverageLean
Set WordApp = New Word.Application 'Forces a New Word Application each and every time. (Prevents Error 462)
If Cells(2, 3).Value <> "" Then 'If a path to Word Documents exist
WordCounter = 2
LastRowPath = Cells(Rows.Count, 3).End(xlUp).Row 'Identify Last Row in Column C
Do Until WordCounter > LastRowPath 'Loop through any Word Documents in Column C
Set WordDocument = WordApp.Documents.Open(Cells(WordCounter, 3).Value)
WordApp.Visible = True
FindReplaceCounter = 2
LastRow = Cells(Rows.Count, 1).End(xlUp).Row 'Identify Last Row in Column A
Do Until FindReplaceCounter > LastRow 'Complete the Find and Replace for all values in Column A & B
Set MyRange = WordApp.ActiveDocument.Content
With MyRange.Find
.Format = True
.MatchWholeWord = True
'.MatchWildcards = True 'Find and Replace Uppercase & Lowercase Text
.Wrap = wdFindContinue
.Forward = True
.Text = Cells(FindReplaceCounter, 1).Value
'.Replacement.Highlight = True 'Highlight the Replacement Text Found
.Replacement.Text = Cells(FindReplaceCounter, 2).Value
.Execute Replace:=wdReplaceAll
End With
FindReplaceCounter = FindReplaceCounter + 1
Loop
WordApp.ActiveDocument.Save
WordApp.ActiveDocument.Close 'Close Active Word Document
WordCounter = WordCounter + 1
Loop
ElseIf Cells(2, 3).Value = "" Then 'If NO paths to Word Documents exist
FolderPath = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - Len(ActiveWorkbook.Name)) 'Active Workbook File Path
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(FolderPath)
For Each oFile In oFolder.Files 'Loop through every File in Active Workbook's folder path
If InStr(1, oFile.Type, "Microsoft Word") <> 0 And InStr(1, oFile.Name, "~") = 0 Then 'If the File Type contains the phrase Microsoft Word and is NOT Lock File
Set WordDocument = WordApp.Documents.Open(FolderPath & oFile.Name)
WordApp.Visible = True
FindReplaceCounter = 2
LastRow = Cells(Rows.Count, 1).End(xlUp).Row 'Identify Last Row in Column A
Do Until FindReplaceCounter > LastRow 'Complete the Find and Replace for all values in Column A & B
Set MyRange = WordApp.ActiveDocument.Content
With MyRange.Find
.Format = True
.MatchWholeWord = True
.Wrap = wdFindContinue
.Forward = True
.Text = Cells(FindReplaceCounter, 1).Value
'.Replacement.Highlight = True 'Highlight the Replacement Text Found
.Replacement.Text = Cells(FindReplaceCounter, 2).Value
.Execute Replace:=wdReplaceAll
End With
FindReplaceCounter = FindReplaceCounter + 1
Loop
WordApp.ActiveDocument.Save
WordApp.ActiveDocument.Close 'Close Active Word Document
End If
Next oFile
End If
WordApp.Quit
MsgBox "The Find and Replace has been completed. Stay Awesome!"
Set oFSO = Nothing
Set oFolder = Nothing
Set oFile = Nothing
Set WordApp = Nothing
Set WordDocument = Nothing
Exit Sub
LeverageLean:
MsgBox (Err.Number & " - " & Err.Description & vbNewLine & vbNewLine & "Don't hesitate to email me: brentschneider#leveragelean.com")
End Sub
'Stay Awesome`