úprava kódu pro hromadný hypertextový odkaz

[luko02420]

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

[elninoslov]

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]

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