PC-HELP.CZ

České diskuzní fórum o počítačích
https://pc-help.cnews.cz/

Makro, hypertextový odkaz

https://pc-help.cnews.cz/viewtopic.php?f=35&t=215532

Stránka 1 z 1

Makro, hypertextový odkaz

Napsal: 12 čer 2020 16:26
od VBApomoc
Dobrý den,

Mohl bych tu někoho zkušeného s VBA požádat o pomoc? Potřeboval vytvořit hypertextový odkaz v listu2, kde by byl text KlikniZDE. Po kliknutí by se otevřela www stránka, která by se ale dynamicky měnila podle obsahu buňky v listu1.

Moc děkuji za pomoc

Re: Makro, hypertextový odkaz

Napsal: 12 čer 2020 21:54
od atari
To chceš 2 různé věci. Hypertextový odkaz lze vytvořit pomécí makra - VBA. Ale www stránku pomocí VBA nevytvoříš.

Re: Makro, hypertextový odkaz

Napsal: 12 čer 2020 22:01
od elninoslov
To stačí vzorcom:

Kód: Vybrat vše

=HYPERLINK(List1!A1;"KlikniZDE")
=HYPERTEXTOVÝ.ODKAZ(List1!A1;"KlikniZDE")


EDIT:
Aha, tak to ma nenapadlo, že to môže byť myslené aj takto.

Re: Makro, hypertextový odkaz

Napsal: 12 čer 2020 22:24
od VBApomoc
Vytvořit webovou stránku nechci a vím, že na to se VBA nepoužívá, zase tak mimo nejsem :lol: Potřebuji to zapsat pomocí makra, aby buňka v listu 2 nic neobsahovala a dala se kdykoliv přepsat, ale přes tlačítko se zase hyp.odkaz obnovil. Na internetu jsem našel pár kódu, ale žádný mi ve finále nefungoval.

Děkuji za radu

Re: Makro, hypertextový odkaz

Napsal: 13 čer 2020 10:02
od elninoslov
Príloha ako to vyzerá?
Načo príloha? Aby sme vedeli akej oblasti sa to týka, z hľadiska možnej automatizácie nastaviť činnosť do Worksheet_Change.
Takže bunka môže nadobudnúť:
a) prázdna - prípadný HL sa z nej zmaže (viď vyššie Worksheet_Change)
b) bez zmysluplných dát, ale s textom "KlikniZDE" spolu s HL, ktorý sa vytvorí na základe stlačenia čudlíku alebo nejakým iným podnetom napr. inej bunky pomocou Worksheet_Change
c) užívateľom dopísané data, čo musí mať opäť za následok zmazanie HL v tej bunke už existujúceho
d) ...

EDIT:
Niečo ako:

Kód: Vybrat vše

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Range("A1"), Target) Is Nothing Then
        On Error Resume Next
        With Range("A1")
            .Hyperlinks(1).Delete
            .Font.ColorIndex = xlAutomatic
            .Font.Underline = False
        End With
    End If
End Sub

Kód: Vybrat vše

Sub Create_HyperLink()
Dim Adr As String
    Adr = Worksheets("List1").Range("A1").Value
    Application.EnableEvents = False
    With Worksheets("List2")
        .Hyperlinks.Add Anchor:=.Range("A1"), Address:=Adr, ScreenTip:=Adr, TextToDisplay:="KlikniZDE"
    End With
    Application.EnableEvents = True
End Sub

Re: Makro, hypertextový odkaz

Napsal: 15 čer 2020 14:53
od VBApomoc
Zdravím,

Super, moc děkuji za pomoc. Druhý varianta funguje : Sub Create_HyperLink()

Sice to je mimo téma, ale řeším ještě jeden podstatný problém. Pracuji ve dvou souborech současně a z jednoho načítám data do druhého. Dělám to pomocí ThisWorksheet Activate a potom Worksheet.Open. Což mi funguje, ale pokaždé když si chci něco načíst, tak nesmím zapomenout druhý soubor uložit. Což se mi pořád děje a pak mi excel spadne. Nejde tohle nějak ošetřit?
Ještě doplním že druhý soubor, ze kterého načítám data je sdílený.

Děkuji

Re: Makro, hypertextový odkaz

Napsal: 15 čer 2020 15:19
od elninoslov
Tie procedúry sú potrebné obidve. Jedna vytvára samotný hyperlink a druhá kontroluje, či sa daná bunka nezmazala, a zmaže hyperlink a formátovanie. Tú adresu si treba ešte poriešiť podľa seba, alebo napíšte akej oblasti sa to týka v prípade viac buniek. To niesú 2 rôzne spôsoby :)
Create_HyperLink ide do normálneho modulu, a Worksheet_Change do modulu daného listu.

Čo sa týka druhého problému. Popis je nedostatočný, a bodla by príloha (citlivé data zmažte). Nevieme, čo znamená "načítám data". Záleží na tom, čo tam presne robíte, aké rozsahy, aké formáty, aké množstvo, podmienky, ... a dalo by sa možno data získavať inak (dočasné vzorce, PowerQuery, ExecuteExcel4Macro,...).

Re: Makro, hypertextový odkaz

Napsal: 15 čer 2020 15:30
od VBApomoc
kód vypadá takto:

Sub načti data
Const Cesta = "G:\..."

HPO = Worksheets("Data").Range("B1")

Workbooks.Open (Cesta)
On Error Resume Next

DN = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 5, False)
DV = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 11, False)
CN = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 7, False)
CV = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 12, False)
ZK = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 4, False)
NPSC = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 9, False)
NM = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 10, False)
NZ = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 8, False)
VPSC = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 14, False)
VZ = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 13, False)
VM = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 15, False)
kus = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 18, False)
rozmery = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 17, False)
vaha = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 20, False)
dopravce = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 22, False)
LDM = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 16, False)
cena = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 26, False)
mena = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 27, False)
KN = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 2, False)
SPZ = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 21, False)
disponentplan = WorksheetFunction.VLookup(HPO, Worksheets("06 Červen").Range("B4:AJ1000"), 34, False)
End sub

To je vlastně všechno. Zmáčknu tlačítko načti data a přesenou se data do prvního souboru. Jenže pokud si to předtím než načtu data neuložím, tak to spadne. Napadlo mě to řešit vložením příkazu na uložení. Aby se provedlo otevření a hned uložení?

Děkuji

Re: Makro, hypertextový odkaz

Napsal: 15 čer 2020 18:05
od elninoslov
Ja by som ten súbor neotváral a použil by som "dolovanie" dočasnými vzorcami do pomocnej oblasti, ktoré sa ihneď po načítaní zmažú. Oblasť D1:AL1. Alebo by som mal stále aktuálne vypočítavané údaje ako v D2:AL2.

Kód: Vybrat vše

Sub Nacti_data()
Dim A(), rngHelp As Range, i As Integer
Dim Cesta As String, Subor As String, LST As String, Adresa As String, HPO As String
   
    Cesta = "G:\"
    Subor = "Zdieľaný zdroj.xlsx"
    LST = "05 Květen"
    Adresa = "$B$4:$AJ$1000"
   
    Set rngHelp = ThisWorkbook.Worksheets("Data").Range("D1").Resize(, Range(Adresa).Columns.Count)
    HPO = ThisWorkbook.Worksheets("Data").Range("B1").Value

    With rngHelp
        .Formula = "=IFERROR(IF(VLOOKUP($B$1,'" & Cesta & "[" & Subor & "]" & LST & "'!" & Adresa & ",COLUMN(A1),FALSE)="""","""",VLOOKUP($B$1,'" & Cesta & "[" & Subor & "]" & LST & "'!" & Adresa & ",COLUMN(A1),FALSE)),"""")"
        A = .Value
        .ClearContents
    End With
   
    DN = A(1, 5)
    DV = A(1, 11)
    CN = A(1, 7)
    CV = A(1, 12)
    ZK = A(1, 4)
    NPSC = A(1, 9)
    NM = A(1, 10)
    NZ = A(1, 8)
    VPSC = A(1, 14)
    VZ = A(1, 13)
    VM = A(1, 15)
    kus = A(1, 18)
    rozmery = A(1, 17)
    vaha = A(1, 20)
    dopravce = A(1, 22)
    LDM = A(1, 16)
    cena = A(1, 26)
    mena = A(1, 27)
    KN = A(1, 2)
    SPZ = A(1, 21)
    disponentplan = A(1, 34)
End Sub
Časové pásmo: UTC+02:00
Stránka 1 z 1
Powered by phpBB® Forum Software © phpBB Limited
https://www.phpbb.com/