Hyperlink automatisieren?

Sub Alle_lesen()
Const iSuch As String = "Buchung XXX"
Const jSuch As String = "Buchung YYY"
Dim strString As String, rngCell As Range
Dim WB As Workbook, rngCellJ As Range
Dim WS As Worksheet: Set WS = ActiveSheet
rr = 1
Pfad = "C:\Users\xxx\Desktop\Test\" '>>
f = Dir(Pfad & "*.xlsx")
Do While f  ""
rr = rr + 1
Set WB = Workbooks.Open(Pfad & f)
'hier dein Code mit WB.Sheets(1). Dim strString As String, rngCell As Range
Set rngCell = WB.Sheets(1).Columns(6).Find(iSuch, lookat:=xlWhole, LookIn:=xlValues,  _
MatchCase:=True)
Set rngCellJ = WB.Sheets(1).Columns(6).Find(jSuch, lookat:=xlWhole, LookIn:=xlValues,  _
MatchCase:=True)
If Not rngCell Is Nothing Then
WS.Cells(rr, 1) = rngCell.Offset(0, 4)
WS.Cells(rr, 2) = WB.Sheets(1).Range("J3")
WS.Cells(rr, 3) = WB.Sheets(1).Range("J4")
End If
If Not rngCellJ Is Nothing Then
WS.Cells(rr, 1) = rngCellJ.Offset(0, 4)
WS.Cells(rr, 2) = WB.Sheets(1).Range("J3")
WS.Cells(rr, 3) = WB.Sheets(1).Range("J4")
End If
WB.Close 0
f = Dir
Loop
End Sub