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 ??
VBA Excel - hypertextový odkaz
- Branscombe
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: VBA Excel - hypertextový odkaz
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
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
Re: VBA Excel - hypertextový odkaz
Ahoj, díky za pomoc, ale nefunguje mi to a nemohu to ani odkrokovat abych se pokusil najít chybu ... :-/
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: VBA Excel - hypertextový odkaz
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:
A pokud mas problemy, tak neni k nicemu napsat, ze mi to nefunguje, je potreba uvest pripadna chybova hlaseni a jine priznaky nefunkcnosti.
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
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
Re: VBA Excel - hypertextový odkaz
No teď už je to OK, ale před tím to nedělalo absolutně nic ... Prostě jsem zapisoval a ani ťuk ...
Díky
Díky
- Branscombe
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
Re: VBA Excel - hypertextový odkaz
Chtěl jsem tam vložit ještě přidat podmínku
tak aby mi to nevyhazovalo s chybou když již složka existuje, ale nějak mi to nejde :-/
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 :-/
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: VBA Excel - hypertextový odkaz
Toto je upravena procedura:
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, 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
-
- Mohlo by vás zajímat
- Odpovědi
- Zobrazení
- Poslední příspěvek
-
- 16
- 6895
-
od mirekol
Zobrazit poslední příspěvek
20 říj 2023 08:31
-
- 2
- 2045
-
od honzzicek
Zobrazit poslední příspěvek
01 črc 2023 08:57
-
- 5
- 2859
-
od mmmartin
Zobrazit poslední příspěvek
13 črc 2023 18:44
-
- 3
- 2316
-
od Story-Long
Zobrazit poslední příspěvek
14 srp 2023 10:11
-
- 1
- 727
-
od Grimm
Zobrazit poslední příspěvek
12 bře 2024 21:43
Kdo je online
Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 5 hostů