• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Hyperlink aanpassen met VBA

Status
Niet open voor verdere reacties.
danny147

danny147

Terugkerende gebruiker
Lid geworden
29 apr 2007
Berichten
4.744
Beste,

Ik heb een honderdtal hypelinks waarvan ik de eerste 28 karakters en de laatste 12 wil verwijden om deze werkende te houden.
In bijlage 3 stuks waarvan de eerste de goede is en de andere moeten aangepast worden met VBA.
Zijn er nog vragen dan hoor ik het graag.
 

Bijlagen

  • test hyperlinks.xlsm
    13,9 KB · Weergaven: 42
Beste HSV,

Deze werkt niet

In bijlage de afbeelding, bovenste is aangepaste met VBA onderstaande de goede via handmatig.
 

Bijlagen

  • Afb hyperlink.docx
    24,2 KB · Weergaven: 33
Volgens je voorbeeld document zou dit voldoende zijn:
Code: 
Sub ehpl()
    Dim hl As Hyperlink
    For Each hl In Columns(1).Hyperlinks
        If Left(hl.Address, 11) = "javascript:" Then
            hl.Address = Mid(hl.Address, 30)
        End If
    Next
End Sub
 
Als dat zo is klopt uiteraard het voorbeeld bestand niet en werkt mijn voorstel ook niet.
 
Beste HSV en edmoor,

Dat het bestandje bij jullie niet gaat werken komt omdat het niet via het Internet lukt maar via ons zelf Intranet wordt gebruikt

@HSV,
Het hyperlinkadres kan ik hier niet plaatsen omdat ik het niet zie als ik RMK en hyperlink bewerken doe.

@edmoor,
Wat jou code betreft werkt deze perfect, maar de laatste 12 karakters zijn niet verwijderd
Dit is het resultaat.

Code: 
http://wfasbprod.sidmar.be/asb.web/#/stelling/0271f5f3-dca3-40f7-99b7-9ac969bd91a3','_blank'))
 
Dan haal je die er ook nog af:
Code: 
Sub ehpl()
    Dim hl As Hyperlink
    For Each hl In Columns(1).Hyperlinks
        If Left(hl.Address, 11) = "javascript:" Then
            hl.Address = Mid(hl.Address, 30, Len(hl.Address) - 12)
        End If
    Next
End Sub
 
Beste edmoor,

De laatste 12 karakters gaan er niet af
Indien het niet lukt heb ik gezien dat deze wel werkt met de karakters erbij
 
Ja, het aantal dat ik gebruikte is ook niet goed natuurlijk.
Dat moet geen 12 maar 42 zijn.
Maar ik had het er in eerste instantie niet bij gedaan omdat de link dan inderdaad al wel werkt.
 
Beste edmoor,

Ook deze keer zijn ze er niet af
Geen probleem, ga deze op opgelost plaatsen ze werkt

Ook HSV bedankt hiervoor
 
Is ook niet goed inderdaad, maandagochtend ;)
Maar als het werkt dan werkt het :)
 
In je voorbeeld document staat trouwens dat _blank gedeelte niet in .Address maar in .SubAddress.
Probeer dit eens:
Code: 
Sub ehpl()
    Dim hl As Hyperlink
    For Each hl In Columns(1).Hyperlinks
        hl.SubAddress = Split(hl.SubAddress, "'")(0)
    Next
End Sub
 
Beste,

De 12 karakters achteraan zouden toch weg moeten
Krijg enkel een blanco blad te zien en dat is niet de bedoeling
Wat laat gezien :eek:
Laatste code werkt trouwens niet
 
Laatst bewerkt:
Wel in je voorbeeld document, dan is die niet goed.
 
Beste edmoor,

In het documentje verwijst de eerste afb naar One Drive dat niet goed is maar zijn wel de laatste 12 karakters verdwenen alsook de link
en de tweede afb is hoe het er moet uitzien.

Nu krijg ik onderstaande te zien, hetgeen goed is behalve de laatste 12 karakters
die zouden weg moeten.

Code: 
[URL]http://wfasbprod.sidmar.be/asb.web/#/stelling/0271f5f3-dca3-40f7-99b7-9ac969bd91a3','_blank'[/URL]))
 
Met mijn voorbeeld uit #5 en het document dat je in #1 plaatste krijg ik er dit uit:
Code: 
http://wfasbprod.sidmar.be/asb.web/
http://wfasbprod.sidmar.be/asb.web/
 
Beste edmoor,

Wat ik krijg met jouw code in #5 is het volgende:
Deze code is perfect als de rode tekst nu nog kan verdwijnen.

Code: 
http://wfasbprod.sidmar.be/asb.web/#/stelling/49249aee-fab5-474d-ac6a-1ab80ff81f8a[COLOR="#FF0000"]','_blank'))[/COLOR]
 
Zonder test, want je hebt nog steeds geen document geplaatst waarin ik dat resultaat krijg:
Code: 
Sub ehpl()
    Dim hl As Hyperlink
    For Each hl In Columns(1).Hyperlinks
        If Left(hl.Address, 11) = "javascript:" Then
            hl.Address = Mid(hl.Address, 30, Len(hl.Address) - 41)
        End If
    Next
End Sub
 
Laatst bewerkt:
Beste edmoor,

Krijg foutmelding bij uitvoeren van de code
In bijlage in document het resultaat van de foutmelding en van vorig resultaat.

Probeer de codes van HSV terug te vinden, maar zijn blijkbaar verdwenen of verwijderd ?
 

Bijlagen

  • Afb hyperlink.docx
    271,8 KB · Weergaven: 23
Als je een foutmelding krijgt, vertel er dan bij welke dat is.
Tevens hebben we niets aan een Word document voor Excel vraag.
Maar #17 zat iets in dat ik nog niet had aangepast, nu wel.
 
Laatst bewerkt:
Beste,

Ook deze werkt niet die ik trouwens al uitgeprobeerd had toen je zei dat het 42 moest zijn.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan