VBA Excel - hypertextový odkaz

[Branscombe]

Ahoj, potřeboval bych makro které by mi při změně dané buňky ve sloupci "A" vložilo do této buňky hypertextový odkaz ve formátu "C:\Program Files\"hodnota z buňky"" a dané umístění by i vytvořilo.

Takže by to mělo fungovat tak že zapíšu do buňky A6 hodnotu "Branscombe" a automaticky se vloží do buňky A6 hypertextový odkaz (C:\Program Files\Branscombe), zobrazená bude v buňce hodnota "Branscombe" a vytvoří se složka "Branscombe" ve složce "C:\Program Files\"

šlo by to ??

[Reklama]

[navstevnik]

Zakladni programova konstrukce je (v editoru VBA voz do modulu tridy prislusneho listu, uprav si dle potreby disk a slozku pro vytvoreni podslozky):

Kód: Vybrat vše

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Response As Byte
  If Target.Column = 1 Then
    If Target.Cells.Count = 1 Then
      If Target.Value <> vbNullString Then
        Response = MsgBox("Jiste vytvorit slozku: " & Target.Value & "?", vbQuestion + vbYesNo + vbDefaultButton2)
        If Response = 6 Then
          Dim fso
          Set fso = CreateObject("Scripting.FileSystemObject")
          fso.CreateFolder ("E:\Excel\" & Target.Value)
          Set fso = Nothing
          Application.EnableEvents = False
          Target.Formula = "=HYPERLINK(""" & "E:\Excel\" & Target.Value & """,""" & Target.Value & """)"
          Application.EnableEvents = True
        End If
      End If
    End If
  End If
End Sub

[Branscombe]

Ahoj, díky za pomoc, ale nefunguje mi to a nemohu to ani odkrokovat abych se pokusil najít chybu ... :-/

[navstevnik]

Udalostni procedury nelze spusti primo v editoru VBA klavesou F5.
Do procedury musis vlozit BreakPoint, a na prislusnem listu vlozit ve sloupci retezec a pak muzes krokovat.
Procedura funguje, problem bude nejspis mezi zidli a klavesnici.
Prikladam upravenou udalostni proceduru, kde diskova jednotka a cesta je zadana v konstante:

Kód: Vybrat vše

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Response As Byte
  Const DiskPath As String = "E:\Excel\"
  If Target.Column = 1 Then
    If Target.Cells.Count = 1 Then
      If Target.Value <> vbNullString Then
        Response = MsgBox("Jiste vytvorit slozku: " & Target.Value & "?", vbQuestion + vbYesNo + vbDefaultButton2)
        If Response = 6 Then
          Dim fso
          Set fso = CreateObject("Scripting.FileSystemObject")
          fso.CreateFolder (DiskPath & Target.Value)
          Set fso = Nothing
          Application.EnableEvents = False
          Target.Formula = "=HYPERLINK(""" & DiskPath & Target.Value & """,""" & Target.Value & """)"
          Application.EnableEvents = True
        End If
      End If
    End If
  End If
End Sub


A pokud mas problemy, tak neni k nicemu napsat, ze mi to nefunguje, je potreba uvest pripadna chybova hlaseni a jine priznaky nefunkcnosti.

[Branscombe]

No teď už je to OK, ale před tím to nedělalo absolutně nic ... Prostě jsem zapisoval a ani ťuk ...

Díky

[Branscombe]

Chtěl jsem tam vložit ještě přidat podmínku

Kód: Vybrat vše

If Dir("E:\Excel\Target.Value") <> "" Then
Exit Sub
Else
...
...


tak aby mi to nevyhazovalo s chybou když již složka existuje, ale nějak mi to nejde :-/

[navstevnik]

Toto je upravena procedura:

Kód: Vybrat vše

Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Response As Byte, OK As Boolean
  Const DiskPath As String = "E:\Excel\"
  If Target.Column = 1 Then
    If Target.Cells.Count = 1 Then
      If Target.Value <> vbNullString Then
        Response = MsgBox("Jiste vytvorit slozku: " & Target.Value & "?", vbQuestion + vbYesNo + vbDefaultButton2)
        If Response = 6 Then
          Dim fso
          OK = True
          Set fso = CreateObject("Scripting.FileSystemObject")
          If Not fso.FolderExists(DiskPath & Target.Value) Then
            fso.CreateFolder (DiskPath & Target.Value)
          Else
            OK = False
          End If
          Set fso = Nothing
          If Not OK Then
            MsgBox "Slozka '" & DiskPath & Target.Value & "' jiz existuje"
            Exit Sub
          End If
          Application.EnableEvents = False
          Target.Formula = "=HYPERLINK(""" & DiskPath & Target.Value & """,""" & Target.Value & """)"
          Application.EnableEvents = True
        End If
      End If
    End If
  End If
End Sub


Kdyz uz byl pro vytvoreni slozky pouzit FileSystemObject (FSO), tak je vhodne pouzit i pro zjisteni, zda existuje.
Zaklad k pouziti je zde http://msdn.microsoft.com/en-us/library ... 85%29.aspx a nespocet dalsich odkazu (Google) vcetne v cestine

Doplneno - nize je pouzit alternativne pro osetreni chyby prikaz GoTo Error :

Kód: Vybrat vše

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Response As Byte
  Const DiskPath As String = "E:\Excel\"
  If Target.Column = 1 Then
    If Target.Cells.Count = 1 Then
      If Target.Value <> vbNullString Then
        Response = MsgBox("Jiste vytvorit slozku: " & Target.Value & "?", vbQuestion + vbYesNo + vbDefaultButton2)
        If Response = 6 Then
          Dim fso
          Set fso = CreateObject("Scripting.FileSystemObject")
          On Error Resume Next
          fso.CreateFolder (DiskPath & Target.Value)
          Set fso = Nothing
          If Err.Number <> 0 Then
            MsgBox "Slozka '" & DiskPath & Target.Value & "' jiz existuje"
            Exit Sub
          End If
          On Error GoTo 0
          Application.EnableEvents = False
          Target.Formula = "=HYPERLINK(""" & DiskPath & Target.Value & """,""" & Target.Value & """)"
          Application.EnableEvents = True
        End If
      End If
    End If
  End If
End Sub