úprava kódu pro hromadný hypertextový odkaz Vyřešeno

Programy pro práci v kanceláři (Word, Excel, Access…=>Office)

Moderátor: Mods_senior

luko02420
Level 2
Level 2
Příspěvky: 203
Registrován: únor 12
Pohlaví: Nespecifikováno
Stav:
Offline

úprava kódu pro hromadný hypertextový odkaz

Příspěvekod luko02420 » 15 dub 2018 09:27

Dobrý den, chtěl bych poprosit o rozšíření makra pro hypertextový odkaz, abych mohl vkládat data hromadně. Pokud to půjde.
Děkuji všem za ochotu.

Kód: Vybrat vše

Private Sub Worksheet_Change(ByVal Target As Range)

  Dim strPathJpg As String

  strPathJpg = "\" 'musi končit lomitkem
 
  If Not Application.Intersect(Range("A:A"), Target) Is Nothing Then
    Application.EnableEvents = False
    On Error Resume Next
    If Target <> "" Then 'prida HT
      Target.Hyperlinks.Add _
        Anchor:=Target, _
        Address:=strPathJpg & Target.Value & ".jpg"
    Else
      Target.Hyperlinks.Delete 'smaze HT
    End If
    On Error GoTo 0
    Application.EnableEvents = True
  End If
End Sub

Reklama
Uživatelský avatar
elninoslov
Level 2.5
Level 2.5
Příspěvky: 366
Registrován: červen 13
Pohlaví: Muž
Stav:
Offline

Re: úprava kódu pro hromadný hypertextový odkaz

Příspěvekod elninoslov » 15 dub 2018 13:44

Skúste tento príklad, či je to to, čo chcete :

Kód: Vybrat vše

Private Sub Worksheet_Change(ByVal Target As Range)
Dim strPathJpg As String, Zmena As Range, Bunka As Range, H(), Pocet As Long

  strPathJpg = "z:\Obrázky\"
  Set Zmena = Intersect(Range("A:A"), Target)
 
  If Not Zmena Is Nothing Then
    Application.EnableEvents = False
   
    With Zmena
      Pocet = .Cells.Count
      ReDim H(1 To Pocet, 1 To 1)
      If Pocet = 1 Then H(1, 1) = .Value2 Else H = .Value2: Pocet = 1
         
      For Each Bunka In .Cells
        With Bunka.Hyperlinks
          If IsEmpty(H(Pocet, 1)) Then .Delete Else .Add Anchor:=Bunka, Address:=strPathJpg & H(Pocet, 1) & ".jpg"
        End With
        Pocet = Pocet + 1
      Next Bunka
    End With
   
    Set Bunka = Nothing: Set Zmena = Nothing: Erase H
    Application.EnableEvents = True
  End If
End Sub

luko02420
Level 2
Level 2
Příspěvky: 203
Registrován: únor 12
Pohlaví: Nespecifikováno
Stav:
Offline

Re: úprava kódu pro hromadný hypertextový odkaz  Vyřešeno

Příspěvekod luko02420 » 15 dub 2018 14:33

Děkuji, to je přesně ono.
Funguje přesně tak jak potřebuji.


  • Mohlo by vás zajímat
    Odpovědi
    Zobrazení
    Poslední příspěvek

Zpět na “Kancelářské balíky”

Kdo je online

Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 7 hostů