Jump to content

SUBIECTE NOI
« 1 / 5 »
RSS
Instalare aer conditionat in apar...

Telefoane prietenoase cu vederea?

Alegere teava pentru incalzire pr...

Opinia publica despre medici/ asi...
 Senzor Temp PMOD-TMP3 cu TCN75A

Amazing Race

La multi ani @LouisCyphre!

Vinieta Bulgaria Online
 Investitie imobiliara in strainat...

Plita inducție gorenje IC340...

info schimbare buletin sectorul 4

Aplicație nivel scazut baterie
 Importul de cod extern avantaje v...

Alegere sistem usi glisante\...

Am primit credit in avans desi op...

Restituire prima casco dupa instr...
 

Creare hyperlink in celula alaturata dupe ce este populata cu informatie

- - - - -
  • Please log in to reply
2 replies to this topic

#1
excentryc

excentryc

    Active Member

  • Grup: Members
  • Posts: 1,530
  • Înscris: 15.07.2005
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.

Attached File  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.


#2
excentryc

excentryc

    Active Member

  • Grup: Members
  • Posts: 1,530
  • Înscris: 15.07.2005
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

#3
excentryc

excentryc

    Active Member

  • Grup: Members
  • Posts: 1,530
  • Înscris: 15.07.2005
Am rezolvat !
Se poate inchide

Anunturi

Chirurgia cranio-cerebrală minim invazivă Chirurgia cranio-cerebrală minim invazivă

Tehnicile minim invazive impun utilizarea unei tehnologii ultramoderne.

Endoscoapele operatorii de diverse tipuri, microscopul operator dedicat, neuronavigația, neuroelectrofiziologia, tehnicile avansate de anestezie, chirurgia cu pacientul treaz reprezintă armamentarium fără de care neurochirurgia prin "gaura cheii" nu ar fi posibilă. Folosind tehnicile de mai sus, tratăm un spectru larg de patologii cranio-cerebrale.

www.neurohope.ro

0 user(s) are reading this topic

0 members, 0 guests, 0 anonymous users

Forumul Softpedia foloseste "cookies" pentru a imbunatati experienta utilizatorilor Accept
Pentru detalii si optiuni legate de cookies si datele personale, consultati Politica de utilizare cookies si Politica de confidentialitate