Office: (Office 2019) VBA für automtaische Hyperlinks erweitern ...

Helfe beim Thema VBA für automtaische Hyperlinks erweitern ... in Microsoft Excel Hilfe um das Problem gemeinsam zu lösen; Hallo zusammen, ich habe in meiner Excelliste in Spalte K fortlaufende Nummern stehen, angefangen von ursprünglich 1 bis mittlerweile 13000. Die erste... Dieses Thema im Forum "Microsoft Excel Hilfe" wurde erstellt von root2k, 2. Januar 2021.

Seite 1 von 2

ROOT2K

root2k

VBA für automtaische Hyperlinks erweitern ...

Hallo zusammen,
ich habe in meiner Excelliste in Spalte K fortlaufende Nummern stehen, angefangen von ursprünglich 1 bis mittlerweile 13000.
Die erste Nummer begann mal in Zeile K7.

Ich habe ein Makro das mir automatisch ohne weitere Abfrage Hyperlinks unter den einzelnen Zahlen hinterlegt, d.h. wenn jetzt die Zahl 13000 heisst, dann sorgt das Makro dafür, dass dort ein Link 13000.pdf hinterlegt wird.
Ohne zu wissen ob es die PDF in dem Ordner auf der Festplatte überhaupt gibt.

Der Code lautet:
Code:

Sub Auto_Hyperlinks_Einfügen()
Dim LetzteZelle As Integer
Dim i As Long
LetzteZeile = Worksheets("Aufträge").Cells(Rows.Count, 11).End(xlUp).Row

For i = 7 To LetzteZeile
ActiveSheet.Hyperlinks.Add anchor:=ActiveSheet.Cells(i, 11), _
Address:="V:Nachweise" & Worksheets("Aufträge").Cells(i, 11).Value & ".pdf"
Next i
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Ich würde jetzt gern folgende Änderung vornehmen: nach anklicken des Buttons zum ausführen des Makro sollte ein Abfragefenster aufgehen in dem ich die von und bis Zeile eingeben muss, auf den Bereich das Makro quasi angewendet werden soll und das auch nur bezogen auf Spalte K.
Außerdem wäre es optimal wenn nur ein Link hinzugefügt wird, wenn es zu der Zahl 13000 auch wirklich in dem Ordner eine 13000.pdf gibt, anosnten sollte die jeweilige Zelle unverändert bleiben.

Kann mir da jemand weiterhelfen, da das über meine bisherigen VBA Kenntnisse hinausgeht ...

Vielen Dank.

:)

root2k, 2. Januar 2021

#1
VOLTI

volti

Hallo,

hier mal eine Idee zu Deinem Anliegen (ungetestet)

Code:

[+][-]

Option Explicit

Sub Auto_Hyperlinks_Einfügen()
Dim iLetzteZeile As Long, iErsteZeile As Long
Dim sErg As String, sArr() As String, sDateiname As String
Dim i As Long
Dim WSh As Worksheet

Set WSh = Worksheets("Aufträge")

iLetzteZeile = WSh.Cells(Rows.Count, 11).End(xlUp).Row
sErg = InputBox("Bitte kommagetrennt die Von-Zeile und die Bis-Zeile eingeben", "Von/Bis-Abfrage", "von 7 bis " & iLetzteZeile)
If StrPtr(sErg) = 0 Then Exit Sub
If sErg = "" Then Exit Sub
sErg = Replace(sErg, "von ", "")
sArr = Split(sErg & " bis " & iLetzteZeile, " bis ")
iErsteZeile = Val(sArr(0))
iLetzteZeile = Val(sArr(1))
If iLetzteZeile < iErsteZeile Then
MsgBox "Endezeile darf nicht kleiner sein als die Anfangszeile!", vbCritical, "Hyperlinks"
Exit Sub
End If

For i = iErsteZeile To iLetzteZeile
sDateiname = WSh.Cells(i, 11).Value & ".pdf"
If Dir$(sDateiname) <> "" Then
WSh.Hyperlinks.Add anchor:=WSh.Cells(i, 11).Value, _
Address:="V:\Nachweise\" & sDateiname ' Überprüfen....
End If
Next i
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

____________
viele Grüße
Karl-Heinz

volti, 4. Januar 2021

#2
RALFP.

RalfP.

Hallo,

alternativ zu voltis: ich habe eine Lösung bereits in Nutzung, mit (fast) dem, was du möchtest.
Da sind viele Functions enthalten, die gebraucht werden. Hab das aus meinem Add-In herausgelöst, sodass es hoffentlich bei dir lauffähig ist. Habs kurz geprüft, bei mir läufts.

Du kannst:
- Zeile wählen ab wann es losgeht
- Spalte wählen, in den die Daten stehen
- alternativ dazu: markiere den Bereich vor Start des Makros, dann wird gefragt, ob du die markierten Zellen verlinken willst.
- auf Wunsch ausgeblendete (weggefilterte) überspringen
- auf Wunsch vorhandene Links löschen
- ganze Verzeichnisbäume unterhalb deines zu wählenden Verzeichnisses werden durchsucht

Was fehlt: .pdf musst du dem DateiString hinzufügen.

Code:

Option Explicit
Const U = vbLf
Const U2 = U & U

Sub UnterlagenVerlink()
Dim Wkb As Workbook, Sht As Worksheet
Dim Bereich As Range, Zelle As Range, Spalte As Variant, eZ As Variant
Dim QuellVerz As String, arrDateien As Variant, Calc As XlCalculation
Dim Idx, DateiName As String, BackSlash As Long, Zaehler As Long, Datensatz As Long, booSelection As Boolean
With Application
.EnableEvents = False
.ScreenUpdating = False
Calc = .Calculation
.Calculation = xlCalculationManual
End With
Set Wkb = ActiveWorkbook
Set Sht = Wkb.ActiveSheet
With Sht
If MsgBox("Dateisuche in einem Ordner mit Unterverzeichnissen. Wenn eine Datei gefunden wird, wird aus der Dokumenten-Nummer ein Link!" & U2 & "Nur wenn folgende Voraussetzungen erfüllt sind!" & U2 & "1. Aktives Arbeitsblatt enthält Spalte mit Dokumenten-Nummer," & U & "2. Alle Unterlagen befinden sich in einem Ordner (auch mit Unterordnern)", vbCritical + vbDefaultButton2 + vbMsgBoxSetForeground + vbSystemModal + vbOKCancel) = vbOK Then
.Activate
If Selection.Count > 1 Then
If MsgBox("Alle selektierten Zellen verlinken?", vbQuestion + vbDefaultButton1 + vbMsgBoxSetForeground + vbSystemModal + vbYesNo) = vbYes Then
booSelection = True
Else
End If
Else
End If
If .AutoFilterMode Then
If .AutoFilter.FilterMode Then
If MsgBox("Nur den gefilterten Bereich verlinken?", vbQuestion + vbMsgBoxSetForeground + vbSystemModal + vbYesNo) = vbNo Then .AutoFilter.ShowAllData
End If
End If
If Not booSelection Then
eZ = InputBox("Die Dokumenten-Nummern stehen ab Zeile [Zahl]:", "Zeile eingeben", 2)
If Not IsNumeric(eZ) Then Exit Sub Else eZ = CLng(eZ)
Spalte = InputBox("In welcher Spalte stehen die Dokumenten-Nummern?", "Spalte eingeben", "B")
If IsNumeric(Spalte) Then
Spalte = CLng(Spalte)
ElseIf IsNumeric(Columns(Spalte).Column) Then
Spalte = CLng(Columns(Spalte).Column)
Else
Exit Sub
End If
End If
If MsgBox("Bitte Verzeichnis wählen, in dessen Unterstruktur alle Dokumente liegen", vbInformation + vbOKCancel + vbMsgBoxSetForeground + vbSystemModal) = vbOK Then
QuellVerz = fcFolderPicker
If QuellVerz = "" Then Exit Sub
ChDrive Left(QuellVerz, 1)
ChDir QuellVerz
arrDateien = SearchingInFolder(arrDateien, QuellVerz)
If booSelection Then
Set Bereich = Selection.SpecialCells(xlCellTypeVisible)
Else
Set Bereich = .Range(.Cells(eZ, Spalte), .Cells(.UsedRange.Rows.Count, Spalte)).SpecialCells(xlCellTypeVisible)
End If
If Bereich.Hyperlinks.Count > 0 Then
If MsgBox("Es sind bereits " & Bereich.Hyperlinks.Count & " Zellen verlinkt. Alle Links vorher löschen?", vbQuestion + vbDefaultButton2 + vbMsgBoxSetForeground + vbSystemModal + vbYesNo) = vbYes Then
For Each Zelle In Bereich
If Zelle.Hyperlinks.Count > 0 Then Zelle.ClearHyperlinks
Next
' Stop
On Error GoTo 0
On Error Resume Next
Bereich.EntireColumn.ClearHyperlinks
If Err Then MsgBox "Fehler beim Hyperlinks löschen, eventuell sind verbundene Zellen in dem gewählten Bereich enthalten. Bitte weniger wählen.", vbCritical
On Error GoTo 0
End If
End If
For Each Zelle In Bereich
If Zelle "" And Zelle.Hyperlinks.Count = 0 Then
Idx = Application.Match(("*" & Zelle.Value & "*"), arrDateien, 0)
If IsError(Idx) Then
ElseIf Idx < LBound(arrDateien) Or Idx > UBound(arrDateien) Then
Else
DateiName = arrDateien(Idx)
BackSlash = InStrRev(arrDateien(Idx), "", , vbTextCompare)
If BackSlash Then DateiName = Mid(DateiName, BackSlash + 1)
.Hyperlinks.Add Zelle, CStr(arrDateien(Idx)), , DateiName, CStr(Zelle.Value)
CPP Zaehler
End If
End If
Next
End If
End If
End With
With Application
.EnableEvents = False
.ScreenUpdating = True
.Calculation = Calc
End With
End Sub

Function fcFolderPicker(Optional Folder As Variant) As String
Dim strOrdner As String
With Application.FileDialog(msoFileDialogFolderPicker)
If IsMissing(Folder) Then
.InitialFileName = ThisWorkbook.Path
Else
.InitialFileName = Folder
End If
.Title = "FolderPicker"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
.AllowMultiSelect = False
If .Show = -1 Then
strOrdner = .SelectedItems(1)
' Stop
If Left(strOrdner, 4) Like "http" Then
strOrdner = fcWebDAVURI(strOrdner)
ElseIf Right(strOrdner, 1) "" Then
strOrdner = strOrdner & ""
Else

End If
Else
strOrdner = ""
End If
End With
fcFolderPicker = strOrdner
End Function

Function SearchingInFolder(ByRef arrDaten As Variant, strFolder As String, Optional ByRef Zaehler As Long, Optional varFileFilter As Variant = "*", Optional AusschlussKriterium As Variant) As Variant()
' auslesen aufrufen mit Ordnername
Dim FSO As Object
Dim SearchingFolder As Object
Dim FD As Object, FI As Object
Dim lngFilesCount As Long ' Laufvariable
Dim varFileName As String

Set FSO = CreateObject("Scripting.Filesystemobject")
Set SearchingFolder = FSO.getfolder(strFolder)
On Error Resume Next
lngFilesCount = SearchingFolder.Files.Count
If Err Then
MsgBox "No access on " & SearchingFolder.Path & U, False, True
On Error GoTo 0
Else
On Error GoTo 0
If lngFilesCount > 0 Then
If IsEmpty(arrDaten) Then
ReDim arrDaten(1 To lngFilesCount)
Zaehler = 0
Else
ReDim Preserve arrDaten(1 To (UBound(arrDaten) + lngFilesCount))
End If
End If
For Each FI In SearchingFolder.Files ''' schleife über alle dateien
varFileName = FI.Name
If Not IsMissing(AusschlussKriterium) Then
If varFileName Like varFileFilter And (Not (varFileName Like AusschlussKriterium)) Then CPP Zaehler: arrDaten(Zaehler) = FI.Path
Else
If varFileName Like varFileFilter Then CPP Zaehler: arrDaten(Zaehler) = FI.Path
End If
Next FI
For Each FD In SearchingFolder.subfolders ' Schleife über alle verzeichnisse
SearchingInFolder arrDaten, FD.Path, Zaehler, varFileFilter, AusschlussKriterium
Next FD
Set FSO = Nothing
End If
SearchingInFolder = arrDaten
End Function

Public Function CPP(ByRef a, Optional B As Integer = 1)
''' C++ emulator for i++, i-- and so on
CPP = a
a = a + B
End Function

Function fcWebDAVURI(URL As String) As String
'Uncomment the below line to test locally without calling the function & remove argument above
'Dim URL As String
Dim SplitURL() As String
Dim i As Integer
Dim WebDAVURI As String
'Check for a double forward slash in the resource path. This will indicate a URL
If Not InStr(1, URL, "//", vbBinaryCompare) = 0 Then
'Split the URL into an array so it can be analyzed & reused
SplitURL = Split(URL, "/", , vbBinaryCompare)
'URL has been found so prep the WebDAVURI string
WebDAVURI = ""
'Check if the URL is secure
If SplitURL(0) = "https:" Then
'The code iterates through the array excluding unneeded components of the URL
For i = 0 To UBound(SplitURL)
If Not SplitURL(i) = "" Then
Select Case i
Case 0
'Do nothing because we do not need the HTTPS element
Case 1
'Do nothing because this array slot is empty
Case 2
'This should be the root URL of the site. Add @ssl to the WebDAVURI
WebDAVURI = WebDAVURI & SplitURL(i) & "@ssl"
Case Else
'Append URI components and build string
WebDAVURI = WebDAVURI & "" & SplitURL(i)
End Select
End If
Next i
Else
'URL is not secure
For i = 0 To UBound(SplitURL)
'The code iterates through the array excluding unneeded components of the URL
If Not SplitURL(i) = "" Then
Select Case i
Case 0
'Do nothing because we do not need the HTTPS element
Case 1
'Do nothing because this array slot is empty
Case 2
'This should be the root URL of the site. Does not require an additional slash
WebDAVURI = WebDAVURI & SplitURL(i)
Case Else
'Append URI components and build string
WebDAVURI = WebDAVURI & "" & SplitURL(i)
End Select
End If
Next i
End If
'Set the fcWebDAVURI value to WebDAVURI
fcWebDAVURI = WebDAVURI
Else
'There was no double forward slash so return system path as is
fcWebDAVURI = URL
End If
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

RalfP., 4. Januar 2021

#3
ROOT2K

root2k

VBA für automtaische Hyperlinks erweitern ...

Vielen Dank euch beiden.
@Ralf: dein Vorschlag passt auf jeden Fall wie die Faust aufs Auge, vielen Dank.

Bezüglich dem Dateinamen nur .pdf als Links hinzufügen habe ich es so abgeändert, läuft noch, passt so?:
Code:

For Each Zelle In Bereich
If Zelle "" And Zelle.Hyperlinks.Count = 0 Then
Idx = Application.Match(("*" & Zelle.Value & ".pdf"), arrDateien, 0)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Das Makro ist ja sehr umfangreich, die Abfrage nach der Spalte dauerhaft auf Spalte K zu setzen ohne Nachfrage zu setzen erfordert einiges an Änderungen?
Genauso mit dem Ordner der auszuwählen ist, den würde ich auch auf den festen Ordner setzen, aber ich glaube das sprengt meine Kenntnisse das alles abzuändern?

root2k, 4. Januar 2021

#4
RALFP.

RalfP.

Guten Morgen,

zum Anfang würde ich dir empfehlen, setze ein Stop am Anfang des Codes, starte das Makro, beim Stop ploppt das VBE Fenster auf, blende das Lokal-Fenster ein. Mit F8 kannst den Code nun im Einzelschritt durchführen. Im Lokal-Fenster siehst du die Stati der Variablen. Im Direktfenster kannst du weitere Stati abfragen. Nur so hast du eine Chance, den Code zu verstehen.

Ich komme frühestens heute Abend dazu, den Code so zu kürzen, wie du es dir wünschst.
In der Zwischenzeit kannst du versuchen, den Code blockweise auszukommentieren, was du nicht brauchst.

"Stop" kannst du direkt als einzelne Zeile in den Code schreiben.
F9 setzt ein temporären Stop.

RalfP., 4. Januar 2021

#5
RALFP.

RalfP.

probier mal aus
den auskommentierten Code kannst du löschen, wenn es läuft

Code:

Option Explicit
Const U = vbLf
Const U2 = U & U

Sub UnterlagenVerlink()
Dim Wkb As Workbook, Sht As Worksheet
Dim Bereich As Range, Zelle As Range, Spalte As Variant, eZ As Variant
Dim QuellVerz As String, arrDateien As Variant, Calc As XlCalculation
Dim Idx, DateiName As String, BackSlash As Long, Zaehler As Long, Datensatz As Long, booSelection As Boolean
With Application
.EnableEvents = False
.ScreenUpdating = False
Calc = .Calculation
.Calculation = xlCalculationManual
End With
Set Wkb = ActiveWorkbook
Set Sht = Wkb.ActiveSheet
With Sht
If MsgBox("Dateisuche in einem Ordner mit Unterverzeichnissen. Wenn eine Datei gefunden wird, wird aus der Dokumenten-Nummer ein Link!" & U2 & "Nur wenn folgende Voraussetzungen erfüllt sind!" & U2 & "1. Aktives Arbeitsblatt enthält Spalte mit Dokumenten-Nummer," & U & "2. Alle Unterlagen befinden sich in einem Ordner (auch mit Unterordnern)", vbCritical + vbDefaultButton2 + vbMsgBoxSetForeground + vbSystemModal + vbOKCancel) = vbOK Then
.Activate
If Selection.Count > 1 Then
If MsgBox("Alle selektierten Zellen verlinken?", vbQuestion + vbDefaultButton1 + vbMsgBoxSetForeground + vbSystemModal + vbYesNo) = vbYes Then
booSelection = True
Else
End If
Else
End If
If .AutoFilterMode Then
If .AutoFilter.FilterMode Then
If MsgBox("Nur den gefilterten Bereich verlinken?", vbQuestion + vbMsgBoxSetForeground + vbSystemModal + vbYesNo) = vbNo Then .AutoFilter.ShowAllData
End If
End If
If Not booSelection Then
eZ = InputBox("Die Dokumenten-Nummern stehen ab Zeile [Zahl]:", "Zeile eingeben", 2)
If Not IsNumeric(eZ) Then Exit Sub Else eZ = CLng(eZ)
Spalte = 11
' Spalte = InputBox("In welcher Spalte stehen die Dokumenten-Nummern?", "Spalte eingeben", "B")
' If IsNumeric(Spalte) Then
' Spalte = CLng(Spalte)
' ElseIf IsNumeric(Columns(Spalte).Column) Then
' Spalte = CLng(Columns(Spalte).Column)
' Else
' Exit Sub
' End If
End If
' If MsgBox("Bitte Verzeichnis wählen, in dessen Unterstruktur alle Dokumente liegen", vbInformation + vbOKCancel + vbMsgBoxSetForeground + vbSystemModal) = vbOK Then
QuellVerz = Environ("USERPROFILE") & "Desktop" ' 0 Then
If IsEmpty(arrDaten) Then
ReDim arrDaten(1 To lngFilesCount)
Zaehler = 0
Else
ReDim Preserve arrDaten(1 To (UBound(arrDaten) + lngFilesCount))
End If
End If
For Each FI In SearchingFolder.Files ''' schleife über alle dateien
varFileName = FI.Name
If Not IsMissing(AusschlussKriterium) Then
If varFileName Like varFileFilter And (Not (varFileName Like AusschlussKriterium)) Then CPP Zaehler: arrDaten(Zaehler) = FI.Path
Else
If varFileName Like varFileFilter Then CPP Zaehler: arrDaten(Zaehler) = FI.Path
End If
Next FI
For Each FD In SearchingFolder.subfolders ' Schleife über alle verzeichnisse
SearchingInFolder arrDaten, FD.Path, Zaehler, varFileFilter, AusschlussKriterium
Next FD
Set FSO = Nothing
End If
SearchingInFolder = arrDaten
End Function

Public Function CPP(ByRef a, Optional B As Integer = 1)
''' C++ emulator for i++, i-- and so on
CPP = a
a = a + B
End Function

Function fcWebDAVURI(URL As String) As String
'Uncomment the below line to test locally without calling the function & remove argument above
'Dim URL As String
Dim SplitURL() As String
Dim i As Integer
Dim WebDAVURI As String
'Check for a double forward slash in the resource path. This will indicate a URL
If Not InStr(1, URL, "//", vbBinaryCompare) = 0 Then
'Split the URL into an array so it can be analyzed & reused
SplitURL = Split(URL, "/", , vbBinaryCompare)
'URL has been found so prep the WebDAVURI string
WebDAVURI = ""
'Check if the URL is secure
If SplitURL(0) = "https:" Then
'The code iterates through the array excluding unneeded components of the URL
For i = 0 To UBound(SplitURL)
If Not SplitURL(i) = "" Then
Select Case i
Case 0
'Do nothing because we do not need the HTTPS element
Case 1
'Do nothing because this array slot is empty
Case 2
'This should be the root URL of the site. Add @ssl to the WebDAVURI
WebDAVURI = WebDAVURI & SplitURL(i) & "@ssl"
Case Else
'Append URI components and build string
WebDAVURI = WebDAVURI & "" & SplitURL(i)
End Select
End If
Next i
Else
'URL is not secure
For i = 0 To UBound(SplitURL)
'The code iterates through the array excluding unneeded components of the URL
If Not SplitURL(i) = "" Then
Select Case i
Case 0
'Do nothing because we do not need the HTTPS element
Case 1
'Do nothing because this array slot is empty
Case 2
'This should be the root URL of the site. Does not require an additional slash
WebDAVURI = WebDAVURI & SplitURL(i)
Case Else
'Append URI components and build string
WebDAVURI = WebDAVURI & "" & SplitURL(i)
End Select
End If
Next i
End If
'Set the fcWebDAVURI value to WebDAVURI
fcWebDAVURI = WebDAVURI
Else
'There was no double forward slash so return system path as is
fcWebDAVURI = URL
End If
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

RalfP., 5. Januar 2021

#6
XLPH 2.0

xlph 2.0

Hallo,

ist das, was du suchst?

Code:

Public Sub Auto_Hyperlinks_Einfügen()
Dim LastRow As Long
Dim Range As Range
Dim Cell As Range
Dim No As String
Dim Path As String

Const cPath As String = "V:Nachweise{#}.pdf"

With ThisWorkbook.Worksheets("Aufträge")
LastRow = .Cells(.Rows.Count, 11).End(xlUp).Row
Set Range = .Range(.Cells(7, 1), .Cells(LastRow, 1))
End With

Range.Hyperlinks.Delete

For Each Cell In Range
No = Cell.Offset(, 10).Value
Path = Replace(cPath, "{#}", No)
If Dir(Path) vbNullString Then
Cell.Hyperlinks.Add _
Anchor:=Cell, _
Address:=Path
End If
Next
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

xlph 2.0, 6. Januar 2021

#7
ROOT2K

root2k

VBA für automtaische Hyperlinks erweitern ...

von RalfP.

probier mal aus
den auskommentierten Code kannst du löschen, wenn es läuft
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Danke, probiere ich nachher direkt nochmal aus.
Aber deine erste Variante ist auch sehr gut. Wenn man sich mal dran gewöhnt hat geht es sehr gut.
Das einzige was ich hatte, dass auf einmal alle 13000 Hyperlinks weg waren.
Aber ich kann nicht nachvollziehen warum ... das neue hinzufügen hat aber sehr gut geklappt. Bis jetzt sind sie auch noch da ;-)

Zuletzt von einem Moderator bearbeitet: 9. Februar 2021

root2k, 6. Januar 2021

#8
RALFP.

RalfP.

Code:

On Error GoTo 0
On Error Resume Next
Bereich.EntireColumn.ClearHyperlinks
If Err Then MsgBox "Fehler beim Hyperlinks löschen, eventuell sind verbundene Zellen in dem gewählten Bereich enthalten. Bitte weniger wählen.", vbCritical
On Error GoTo 0
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Das ist zu viel, kommentiere das aus, denn sollten nicht mehr alle Links gelöscht werden. Davor werden alle Hyperlinks mit einer Schleife einzeln je Zelle gelöscht, denn kommt nochmal dieser Code, der dann alle löscht.

Selbst wenn Bereich exklusive ausgeblendeter Zellen ist, werden dennoch alle gelöscht. Wenn man das per Hand macht, ist das auch so. It's not a bug, It's a feature.. *biggrin.gif*

RalfP., 6. Januar 2021

#9
ROOT2K

root2k

Super das passt.

Ein Fehler was in meiner Tabelle jetzt passiert ist: ich habe z.B. die Zahl 3 und dazu die 3.pdf.
Das automatische hinzufügen hat bei der Zahl 3 jetzt aber die 10003.pdf hinterlegt.
Also es müsste quasi genau die 3.pdf zuordnen.
Wobei es aber für andere Fälle wieder geht wenn ganze Namen durchsucht werden.
Z.B. haben die Zahl 10000 und 10001 die gleiche PDF. Die heißt dann 10000+10001.pdf. Da hat er bei beiden Zahlen / Zellen jeweils die PDF hinterlegt als Link. Wahrscheinlich weil beim Dateiformat * angegeben ist. Wenn ich jetzt explizit nach den genauen Stellen suchen lassen würde lso bei 3.pdf nur eben die 1 Stelle suchen, dann würde es bei den kombinierten PDF's nicht mehr funktionieren.
Das ist wahrscheinlich etwas knifflig das hinzubekommen?

root2k, 8. Januar 2021

#10
RALFP.

RalfP.

du musst dich entscheiden was du willst
alles, was logisch und programmatisch durchführbar ist, ist auch möglich
versuche wie wenn, dann, sonst zu denken und prüfe, ob die ergebnisse deinen erwartungen entsprechen

*3.pdf findet auch 3333.pdf, aber nicht 3332.pdf
*3*.pdf findet sowohl 3332.pdf als auch 3333.pdf
3.pdf findet nur 3.pdf

du kannst auch 2 schleifen laufen lassen
1. [string].pdf
2. *[string]*.pdf

RalfP., 8. Januar 2021

#11
ROOT2K

root2k

Ja verstehe,
also im prinzip wäre es ja so am richtigsten: *[string]*.pdf, wobei der String sich genau auf die Zahl in der Zelle beziehen sollte, also wenn dann in Zelle K7 ein Wert z.B. 10000 steht müsste er ja mit *10000*.pdf genau diese finden auch wenn die PDF 10000+10001.pdf heißt richtig?

Wie baue ich das am besten ein?

root2k, 10. Januar 2021

#12
ROOT2K

root2k

VBA für automtaische Hyperlinks erweitern ...

von RalfP.

*3.pdf findet auch 3333.pdf, aber nicht 3332.pdf
*3*.pdf findet sowohl 3332.pdf als auch 3333.pdf
3.pdf findet nur 3.pdf

du kannst auch 2 schleifen laufen lassen
1. [string].pdf
2. *[string]*.pdf
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Hallo Ralf,
ich muss nochmal darauf zurückkommen, habe jetzt mehrfach rumgedoktert aber bekomme das nicht hin.
Wie baue ich die 2 Schleifen so ein, d.h. das er als ersten [string].pdf durchläuft und wenn da nichts passendes gefunden wurde nach *[String]*.pdf absucht bzw. dann auch einträgt ...?

Zuletzt von einem Moderator bearbeitet: 9. Februar 2021

root2k, 26. Januar 2021

#13
RALFP.

RalfP.

zeig mal dein Code, denn doktor ich daran rum..

RalfP., 27. Januar 2021

#14
ROOT2K

root2k

von RalfP.

zeig mal dein Code, denn doktor ich daran rum..
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Hallo Ralf,

also ich habe versucht den Bereich anzupassen:
Code:

For Each Zelle In Bereich
If Zelle "" And Zelle.Hyperlinks.Count = 0 Then
Idx = Application.Match(("*" & Zelle.Value & ".pdf"), arrDateien, 0)
If IsError(Idx) Then
Idx = Application.Match(("*" & Zelle.Value & "*.pdf"), arrDateien, 0)
ElseIf Idx < LBound(arrDateien) Or Idx > UBound(arrDateien) Then
Else
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Hab einfach den Idx Teil als .pdf angegeben, dann hat er auch genau die 10000.pdf gesucht und gefunden und than habe ich einfach als Then Bedingung die Idx nochmal angegeben aber mit *.pdf und hab mir gedacht dann würde er wenn er nicht genau die PDF findet weitersuchen und bei Mehrfachnamen auch die 10001 finden wenn die PDF 10001+10002.pdf heißt ...
Aber so richtig läuft das nicht, vielleicht bin ich da auf dem Holzweg

Zuletzt von einem Moderator bearbeitet: 9. Februar 2021

root2k, 28. Januar 2021

#15

(Du musst angemeldet oder registriert sein, um eine Antwort erstellen zu können.)

Seite 1 von 2

Thema:

VBA für automtaische Hyperlinks erweitern ...

Die Seite wird geladen...

VBA für automtaische Hyperlinks erweitern ... - Similar Threads - VBA automtaische Hyperlinks
Datei in mehreren Ordnern suchen und wenn gefunden öffnen?! Macro / VBA
in Microsoft Excel Hilfe
Datei in mehreren Ordnern suchen und wenn gefunden öffnen?! Macro / VBA: Hallo Leute, Hoffentlich könnt ihr mir hier helfen, ich krieg den Syntax einfach nicht hin (wahrscheinlich ist es auch totaler käse den ich programmiert habe). Also im Grunde soll eine Datei...
Textteile aus Zelle mit mehreren Absätzen
in Microsoft Excel Hilfe
Textteile aus Zelle mit mehreren Absätzen: Hallo, ich habe folgendes Problem: Ich habe in einer Liste in einer Zelle mehrere Angaben aus denen ich Textteile (z.B. alles was in () oder {} ist) herausziehen will, um damit weiter zurechnen....
Aufrufen Datei aus SharePoint per VBA
in Microsoft Access Hilfe
Aufrufen Datei aus SharePoint per VBA: Wer kann mir helfen. In meiner Firma gibt es Dateien in diversen Ordner in Form von SharePoints, worauf alle Kolleginnen und Kollegen zugreifen kann. Dort habe ich eine Excel-Vorlage, worin die...
VBA: Spalten auf anderen Worksheeds in der Mappe ausblenden.
in Microsoft Excel Hilfe
VBA: Spalten auf anderen Worksheeds in der Mappe ausblenden.: Hallo zusammen, Eine Tabelle mit 9 Worksheets, Datenblatt, Studien, Studie_1 ...Studie_7. Auf dem Deckblatt werden in Zelle B4-B10 die Namen der Studien eingetragen. Davon abhängig ob ein Name...
VBA Zeilen kopieren mit Bedingung
in Microsoft Excel Hilfe
VBA Zeilen kopieren mit Bedingung: Hallo zusammen, Ich möchte per Makro Zeilen aus Tabelle2 in Tabelle3 kopieren, wenn eine Bedingung erfüllt ist. Bedingung: Der Wert in Spalte E (Tabelle2) kommt in Tabelle1 in Spalte E vor....
VBA - Datensätze ans Ende einer anderen Tabelle kopieren
in Microsoft Excel Hilfe
VBA - Datensätze ans Ende einer anderen Tabelle kopieren: Hallo zusammen, ich habe gerade eine "Abrechnungs"-Datei für einen Kindergartenbasar erstellt. Es wäre klasse, wenn man per Schaltfläche die Datensätze aus der Tabelle "Kaeufer" ans Ende der...
Laufzeitfehler 9 VBA
in Microsoft Excel Hilfe
Laufzeitfehler 9 VBA: Nschdem ich die Office Version von 2010 auf 2019 aktualisiert habe wird mir der Laufzeitfehler 9 ausgegeben. Das ist der Code Sub FiberCollect() Dim NumRows As Long 'letzte celle Dim Counter As...

Anmelden oder registrieren

Suche

Diese Seite verwendet Cookies, um Inhalte zu personalisieren, diese deiner Erfahrung anzupassen und dich nach der Registrierung angemeldet zu halten.
Auf dieser Website werden Cookies für die Zugriffsanalyse und Anzeigenmessung verwendet.
Wenn du dich weiterhin auf dieser Seite aufhältst, akzeptierst du unseren Einsatz von Cookies.

Akzeptieren Weitere Informationen...

Information ausblenden