Find words in visio

Question

I´m trying to find some words that appear in a column in excel in visio, and then extract the rest of the sentence from that visio.

I have been able to do this in word, but I´m unable to do it in visio. This is the code that I have used to find it in word, I want to replicated it to find the same words in visio. Any help will be greatly appreciated:

Public wrdApp As New Word.Application
Public wrdDoc As Word.Document
Public WordElem_vsd As String
Public WordElem As String

 Sub findSubprocesos()

Dim fso As New FileSystemObject
Dim f As Folder, sf As Folder
Dim myLastRow As Long
Dim FindWord As String
Dim List As String
Dim Dict As Object
Dim NextFormula As Range
Dim RefElem As Range
Dim Dict_vsd As Object
Dim NextFormula_vsd As Range
Dim RefElem_vsd As Range
Dim Key

TimeStart = Timer

NARRATIVA_RUTA = Worksheets("Datos2").Range("M6").Value
Sheets("Subprocesos").Visible = True

'Obtiene el nombre de las narrativas
Sheets("Datos2").Visible = True
Sheets("Datos2").Activate
Set fso = CreateObject("Scripting.FileSystemObject")

 'Indicate the path were the words are located.
 Set f = fso.GetFolder(NARRATIVA_RUTA)
 x = 3
    For Each sf In f.SubFolders
    For Each ofile In sf.Files
 If fso.GetExtensionName(ofile.path) = "docx" Then
   ActiveSheet.Cells(x, 24) = ofile.Name

x = x + 1

End If
Next
Next

 'Start loop word
 Set Dict = CreateObject("Scripting.Dictionary")
 Set NextFormula = Worksheets("Datos2").Range("V3:V50")

With Dict
    For Each RefElem In NextFormula
         If Not .Exists(RefElem) And Not IsEmpty(RefElem) Then
                WordElem = RefElem
                On Error GoTo skip
                FindSubs_word
        End If
                Next RefElem

 End With
 skip:

    Worksheets("Narrativas").Range("N1").End(xlDown).Offset(1, 0).Value = TotalTime
    TimeStop = Timer
    TotalTime = Round((TimeStop - TimeStart) / 60, 2)
 End Sub

 Public Sub FindSubs_word()

Dim wrdApp As New Word.Application
Dim wrdDoc As Word.Document
Dim cRng As Word.Range
Dim nRng As Word.Range
Set wrdApp = CreateObject("Word.Application")
Dim FindWord As String
Dim List As String

Dim Dict As Object
Dim NextFormula As Range
Dim Key
Dim Wbk As Workbook: Set Wbk = ThisWorkbook

Dim oRange As Range

'Clean list were the range is entered
Worksheets("Datos2").Range("T3:T50").ClearContents
wrdApp.Visible = True

'Find the path from each word doc
ANTIGUA_NARRATIVA_RUTA = Worksheets("Datos2").Range("N7").Value
path_subprocess = ANTIGUA_NARRATIVA_RUTA & "\" & WordElem

On Error GoTo end_loop
Set wrdDoc = wrdApp.Documents.Open(path_subprocess, OpenAndRepair:=True)

Set cRng = wrdDoc.Content
Set nRng = wrdDoc.Content
    
Dim cell As Range
Dim bIsEmpty As Boolean

'Start the loop, looking for each word in the column set and then extracting the 
sentence that follows.
bIsEmpty = False
For n = 3 To 20
For Each cell In Worksheets("Datos2").Range("Z" & n)
    If IsEmpty(cell) = False Then

FindWord = Wbk.Sheets("Datos2").Range("S" & n).Value  'Modify as necessary.

'cRng.Selection.WholeStory
cRng.FIND.ClearFormatting
With cRng.FIND
    
    .ClearFormatting
    .Text = FindWord
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = True
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    
    'If found extract the rest of the sentence
    If .Execute Then
        cRng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        cRng.MoveEnd Unit:=wdSentence, Count:=1
        
        
        Sheets("Datos2").Range("T" & n).Value = cRng
    
    'If not found go to the next document (this is because I´m trying to find title 
     numbers. They are in order)
    'Al no encontrar un subproceso, el proceso asume que ya no hay más subprocesos por 
     lo que el último subproceso que ha encontrado es el último subproceso que hay en 
     esta narrativa.
    Else
        Sheets("Datos2").Range("T" & n).Value = "NO HAY MÁS SUBPROCESOS"
        wrdApp.Quit SaveChanges:=0
        Sheets("Datos2").Range("T3:T50").Copy 
 Sheets("Subprocesos").Range("B3:B50").End(xlToRight).Offset(0, 1)
        GoTo Stop_loop
    End If
    End With
    
 End If
 Next cell
 Next

 end_loop:

wrdApp.Quit SaveChanges:=0
Worksheets("Subprocesos").Range("D2:AA2").Value = 
 Worksheets("Datos2").Range("AM2:BN2").Value 
 vsd_subfolders

 Stop_loop:

 End Sub