Creare hyperlink in celula alaturata dupe ce este populata cu informatie

Salut,

Se da tabelul din imagine.
Sunt pe celula F5 in care am textul "WWW", apas pe butonul de comada de mai sus "click me to generate link".
Dupa ce executa comanda imi populeaza celulele C5, D5, E5 si G5 cu informatii luate dintr-un fisier excel.
As vrea ca dupa ce apare informatia in celula G5 (RRR) sa excute si crearea de hyperlink pentru G5.
Va multumesc.

 test Hyperlink.JPG   50.05K   32 downloads

LE: Adaug urmatoarele infromatii.
1. click me to generate link genreaza link pentru celula F5
2. Link-urile sunt pentru o retea interna

Edited by excentryc, 15 December 2023 - 12:32.

Adaug si codul initial pentru a fi mai usor:

Private Sub CLink_Click()

    Dim sValue As String
    Dim sProj As String
    Dim sLink As String
    Dim sParent As String
    Dim bDFC As Boolean
    Dim iRow As Integer
    Dim xl As Excel.Application
    Dim xlB As Excel.Workbook
    Dim xlS As Excel.Worksheet
    Dim sPhase As String
    Dim sDrawing As String
    Dim sDrawingName As String
    Dim sCheck As String
    Dim sDescription As String
    Dim sDFC As String
    Dim sFile As String
    Dim FilePath As String
    Dim ExtFind As String
  
    bDFC = False
    iRow = ActiveCell.Row
  
    'Text for link
    sValue = ActiveCell.Value
  
   'Project
    If InStr(Cells(iRow, 3).Value, "H79") Then
    sProj = "02_H79"
    End If
    If InStr(Cells(iRow, 3).Value, "X61") Then
    sProj = "01_X61"
    End If
    If InStr(Cells(iRow, 3).Value, "BJA") Then
    sProj = "04_BJA"
    End If
    If InStr(Cells(iRow, 3).Value, "XFK_B") Then
    sProj = "08_XFK_B"
    End If
    If InStr(Cells(iRow, 3).Value, "HJB") Then
    sProj = "07_HJB"
    End If
    If InStr(Cells(iRow, 3).Value, "B1318") Then
    sProj = "09_B1318"
    End If
    sParent = Left(ActiveWorkbook.Path, InStrRev(ActiveWorkbook.Path, "\"))
    'Link path
    If Len(sValue) > 11 Then
    FilePath = sParent & "01_PROJECT\" & sProj & "\DFC 2023\CAD MARK\"
    sFile = Dir(FilePath & sValue & "*")
    ExtFind = Right$(sFile, Len(sFile) - InStrRev(sFile, "."))
  
    sLink = sParent & "01_PROJECT\" & sProj & "\DFC 2023\CAD MARK\" & sValue & "." & ExtFind
    bDFC = True
  
  Else
    sLink = sParent & "01_PROJECT\" & sProj & "\DFC 2023\EDS MARK\" & sValue & "\"
    End If

    'add hyperlink
    If Len(Dir(sLink)) Then
    'Application.CutCopyMode = False
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=sLink, TextToDisplay:=sValue
    'Fill Phase & PI Number Issue Level
    If bDFC Then
    Set xl = CreateObject("Excel.Application")
    Set xlB = xl.Workbooks.Open(sLink)
    xl.Visible = False
    Set xlS = xlB.Worksheets(1)
    sDrawingName = xlS.Cells(9, 25).Value
    sDescription = xlS.Cells(11, 11).Value
    sDFC = xlS.Cells(7, 33).Value
    If sDFC = "" Then sDFC = "INTERN"
    sPhase = xlS.Cells(4, 8).Value
    sDrawing = xlS.Cells(9, 1).Value & " " & xlS.Cells(8, 19).Value
    sCheck = xlS.Cells(7, 11).Value
    xlB.Close Savechanges:=False
    xl.Quit
    Set xl = Nothing
    Set xlB = Nothing
    Set xlS = Nothing
    Cells(iRow, 15).Value = sPhase
    Cells(iRow, 17).Value = sDrawing
    Cells(iRow, 18).Value = sCheck
    Cells(iRow, 4).Value = sDrawingName
    Cells(iRow, 16).Value = sDescription
    Cells(iRow, 7).Value = sDFC
  
  
    End If
    Else
    MsgBox "Hopa!!! Ceva nu e bine." & vbCr & vbCr & "Verifica numele folderului cu cel din celula, poate este un spatiu in plus pe undeva." & vbCr & vbCr & "In Folder sa nu existe un alt folder singur"
  
    End If
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, Cancel As Boolean)
    'The 1st method is coded to launch when a curtain cell is  selected
    If target.Column = 9 Or target.Column = 10 Or target.Column = 14 Or target.Column = 23 Then
    CalendarFrm.Show
    End If
End Sub
Sub x()

    Dim h As Hyperlink

    For Each h In ActiveSheet.Hyperlinks
    h.Address = Replace(h.Address, "\AppData\Roaming\Microsoft", "")
'// h.TextToDisplay = "Something Else"
    Next

End Sub

Am rezolvat !
Se poate inchide