Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1724to1728
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Link zu PDF-Datei erstellen

Link zu PDF-Datei erstellen
05.12.2019 19:40:53
Michael
Hallo zusammen,
ich brauche mal wieder Eure Hilfe und zwar, möchte ich in meinem Datenblatt Zelleninhalte zu gleichnamigen PDF-Dateien verlinken.
Genau gesagt, ab der Zelle E:10 bis Zelle E:10000 stehen Auftragsnummern (z.B. 1234 ) dazu habe ich auf dem Laufwerk D:\ einen Ordner mit dem Namen AUFTRAG, in dem gleichnamige PDF Datei gespeichert sind ( z.B. 1234.pdf ).
Jetzt wollte ich mit VBA nach den PDF Dateien suchen lassen und falls eine mit dem gleichen Namen gefunden wird , diese mit dem Inhalt zu verlinken.
Für Eure Hilfe bedanke mich ganz herzlich

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Link zu PDF-Datei erstellen
05.12.2019 23:36:44
Henner
Hallo Michael
Auf die Schnelle, teste mal:

Option Explicit
Sub Verlinken()
Dim L As Long
Dim cnt As Long
Dim lngLRow As Long
Dim strOrdner As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Ordner ausw?hlen..."
.ButtonName = "Auswahl"
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strOrdner = .SelectedItems(1)
If Right(strOrdner, 1)  "\" Then strOrdner = strOrdner & "\"
Else
strOrdner = ""
End If
End With
If strOrdner = "" Then
MsgBox "Abbruch durch Benutzer (Kein Ordner ausgew?hlt)"
Exit Sub
End If
lngLRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
cnt = 0
If lngLRow  "" Then
.Hyperlinks.Add anchor:=.Range("E" & L), Address:=strOrdner & "\" & .Range("E" & L). _
Value & ".pdf"
cnt = cnt + 1
End If
Next
End With
MsgBox "Bei " & cnt & " von " & L - 5 & " Auftragsnummern wurde ein Dokument verlinkt"
End Sub

Funktioniert? Gruss Henner
Anzeige
KORREKTUR: Link zu PDF-Datei erstellen
06.12.2019 00:02:06
Henner
Sorry: Du wolltest ja ab Zeile 10, nicht ab Zeile 5.
Dann so:

Option Explicit
Sub Verlinken()
Dim L As Long
Dim cnt As Long
Dim lngLRow As Long
Dim strOrdner As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Ordner ausw?hlen..."
.ButtonName = "Auswahl"
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strOrdner = .SelectedItems(1)
If Right(strOrdner, 1)  "\" Then strOrdner = strOrdner & "\"
Else
strOrdner = ""
End If
End With
If strOrdner = "" Then
MsgBox "Abbruch durch Benutzer (Kein Ordner ausgew?hlt)"
Exit Sub
End If
lngLRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
cnt = 0
If lngLRow  "" Then
.Hyperlinks.Add anchor:=.Range("E" & L), Address:=strOrdner & "\" & .Range("E" & L). _
Value & ".pdf"
cnt = cnt + 1
End If
Next
End With
MsgBox "Bei " & cnt & " von " & L - 10 & " Auftragsnummern wurde ein PDF Dokument verlinkt"
End Sub

Funktioniert? Gruss Henner
Anzeige
AW: KORREKTUR: Link zu PDF-Datei erstellen
07.12.2019 17:10:21
Michael
Hallo Henner,
ich konnte erst heute testen.
funktionier so weit, die Hyperlinks werden gesetzt. Allerdings wenn ich die Mappe schlisse und neu öffne nicht mehr.
Bekomme Meldung ,Datei könnte nicht geöffnet werden
Hast Du eine Idee warum ?
Gruß
Michael
AW: KORREKTUR: Link zu PDF-Datei erstellen
07.12.2019 21:24:26
Henner
Hallo Michael
Bei mir geht's einwandfrei. Lade mal Deine Mappe hoch, dann wird sich schnell zeigen wo's hakt. Und denke daran, diesen Beitrag auf offen zu stellen (Haken über Textfeld setzen). Ich setze den Beitrag jetzt nicht auf offen, Du wirst ihn wohl verfolgen. Gruss Henner
AW: KORREKTUR: Link zu PDF-Datei erstellen
08.12.2019 11:28:37
Michael
Hallo Henner,
meine Arbeitsmappe wird mit einem Makro stündlich gespeichert und zusätzlich eine Kopie im Archiv Ordner abgelegt. Wenn ich dieses Makro auskommentiere dann funktioniert es.
Option Private Module 'damit die Prozeduren nicht von außerhalb dieser Datei aufgerufen werden können
Public taktzeit 'permanente Variable der Prozedur "Takt"
Public Sub Speichern() 'der aktuelle Stand wird im Verzeichnis Arbeitspfad und (mit Zeitstempel) _
im Verzeichnis Sicherungspfad gespeichert
Dim aktpfad As String
Dim Datpfad As String
With ThisWorkbook.Sheets("BPS_MF_Buch")
arbpfad = "X:\B\02_Produktion\BPB_S_X\BPS_Schichtprotokolle_Tagesberichte"
sichpfad = "X:\B\02_Produktion\BPB_S_X\BPS_Schichtprotokolle_Tagesberichte\ _
Archiv_MF_Buch_BPS"
Set fs = CreateObject("Scripting.FileSystemObject") 'damit man die Dateizugriffsfunktionen  _
nutzen kann
If Not fs.folderexists(arbpfad) Then
MsgBox ("Arbeitspfad " & Chr(10) & arbpfad & Chr(10) & "existiert nicht!")
GoTo EndeSub
Else
If Not Right(arbpfad, 1) = "\" Then
arbpfad = arbpfad & "\"
End If
End If
If Not fs.folderexists(sichpfad) Then
MsgBox ("Sicherungspfad " & Chr(10) & sichpfad & Chr(10) & "existiert nicht!")
GoTo EndeSub
Else
If Not Right(sichpfad, 1) = "\" Then
sichpfad = sichpfad & "\"
End If
End If
Application.DisplayAlerts = False
ThisWorkbook.SaveCopyAs sichpfad & fs.GetBasename(ThisWorkbook.Name) & "_" & Year(Date) & " _
_" & Format(Month(Date), "00") _
& "_" & Format(Day(Date), "00") & "_" & Format(Hour(Time), "00") & "_" & Format(Minute(Time) _
, "00") & "." & fs.GetExtensionname(ThisWorkbook.Name)
Application.DisplayAlerts = True
aktpfad = CurDir
Datpfad = ThisWorkbook.Path & "\"
On Error GoTo EndeSub
If Datpfad = arbpfad Then
Application.EnableEvents = False 'damit diese Prozedur nicht noch einmal durch sich  _
selbst aufgerufen wir
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
Application.EnableEvents = True
Else
Application.EnableEvents = False 'damit diese Prozedur nicht noch einmal durch sich  _
selbst aufgerufen wir
Application.DisplayAlerts = False
ThisWorkbook.SaveAs arbpfad & ThisWorkbook.Name
Application.DisplayAlerts = True
Application.EnableEvents = True
End If
On Error Resume Next
End With
EndeSub:
Application.EnableEvents = True
Set fs = Nothing
End Sub

Public Sub TaktStarten() 'Softwarestand: 13.12.2016
'liest die Taktfrequemnz in [min] aus EinstellungenSpeicherfrequenz und startet einen Takt zum  _
Zeitpunkt Jetzt + Taktfrequenz
Dim taktfreq As Byte
Dim std As Date
Dim Min As Date
Dim taktzeit As Date
taktfreq = ("60")
std = taktfreq \ 60
Min = taktfreq - std * 60
taktzeit = Now() + TimeValue(Format(std, "00") & ":" & Format(Min, "00") & ":00")
Application.OnTime taktzeit, "Takt", Schedule:=True
End Sub
'TaktStarten
Public Sub TaktStoppen() 'Softwarestand: 13.12.2016
On Error Resume Next
Application.OnTime taktzeit, "Takt", Schedule:=False 'Takt stoppen, falls er noch läuft
On Error GoTo 0
End Sub
'TaktStoppen
Public Sub Takt() 'Softwarestand: 13.12.2016
'Für diese Routine sind folgende globale Variablen notwendig:
'- taktzeit
'Taktfunktion:
'speichert die Datei und eine Sicherubngskopie (mit Zeitstempel) und startet den Takt neu
'Erzeugt durch Rekursivaufruf von sich selbst einen Takt mit "taktzeit" in [min]
Call TaktStoppen
Application.EnableCancelKey = xlDisabled 'damit die ESC-Taste nicht zu einem Abbruch führt,  _
wenn sie während dieser Routine gedrückt wird
On Error Resume Next
aktwbname = ActiveWorkbook.Name
On Error GoTo 0
Datei = ThisWorkbook.Name
If Datei  aktwbname Then
GoTo EndeSub
End If
Call Speichern
EndeSub:
Call TaktStarten 'ruft sich selbst wieder auf, um einen kontinuierlichen Takt zu erzeugen
End Sub

Anzeige

306 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige