Office: VBA: Ordnerinhalt auslesen Hyperlink anlegen und nach Kriterien zuordnen

Hallo Office Community!

Ich bin Neuling, hier im Forum und auch mit Excel VBA.

Nachdem ich Video2Brain Excel VBA studiert habe, kenne ich nun die Grundprinzipien von VBA.
Aber leider kann ich damit nicht mein Problem lösen.
Ich hoffe ihr habt ein Lösung für mich.


Ich möchte mittels Makro in eine Excelliste, die ich aus SAP ausleite, Hyperlinks zu Dateien einfügen.
Diese Dateien (die auch aus SAP ausgeleitet sind) sollen in einem Unterordner liegen,
der in dem gleichen Ordner wie die Excelliste ist.

Warum Unterodner?:
Somit kann ich die Liste auch leicht verschieben oder per Email verschicken, die Hyperlinks sollen als auf
gleicher Pfadebene zu diesem Unterordner zeigen.


Die Zuordnung der Hyperlinks zu den einzelnen Zeilen soll mit einer bestimmten Logik erfolgen.
Die Dateien haben folgendes Format, wobei alle Informationen durch einen "_" von einander getrennt sind.
Allerdings finden sich nicht alle in einer Excel Zelle wieder.

abc_11-4444-999999_000_A_HHHHH-012345.tif -------> Kriterium: A und HHHHH-012345
abc_11-4444-888888_000_C_HHHHH-034567_001.tif -------> Kriterium: C und HHHHH-034567 001
abc_11-4444-888888_000_C_HHHHH-034567_002.tif -------> Wichtig: 002 sagt, das das .tif aus zwei Blättern besteht, die Hyperlinks sollten dann also nebeneinander stehen, da es sich immer um das Dokument HHHHH-034567 handelt.
abc_11-3863-456783_000_A_HHHHH-056789.tif -------> Kriterium A und HHHHH-056789
abc_DIN123_000_C_A23456789_001.tif -------> Kriterium: C A23456789 001
abc_DIN123_000_C_A23456789_002.tif -------> Kriterium: C A23456789 002
abc_gg-098_000_C_A000009239_001.tif -------> Kriterium: A und A000009239
abc_gg-098_000_C_A000009239_001.pdf -------> Kriterium: zu dem obigen tif gehört auch ein .pdf, die Hyperlinks sollten dann also nebeneinander stehen.
xyz_bw000000001_G_EN_001.pdf -------> Kriterium: G bc000000001
abc_bw000000452_A_EN_001.tif -------> Kriterium: A bc000000452
abc_bw004730028_G_000.tif -------> Kriterium: G bc004730028
abc_bs004937929_G_000.pdf -------> Kriterium: G bc004730028
xyz_bs023399333_V_EN_001.pdf -------> Kriterium: V bc023399333
xyz_bs023399333_V_EN_002.pdf -------> Kriterium: V bc023399333

Excelliste hat dann folgendes Format:

abc 000 A HHHHH-012345
abc 000 C HHHHH-034567
abc 000 A HHHHH-056789
abc 000 C A23456789
abc 000 C A000009239
xyz EN G bw000000001
abc EN A bw000000452
abc 000 G bw004730028
abc 000 G bs004937929
xyz EN V bs023399333


Das Makro sollte nun in jeder Zeile die entsprechenden Hyperlinks setzen.
Wobei bei mehreren Dateien sollen diese einfach in Reihenfolge nebeneinander sein,
Wenn es zu den Kriterien in einer Zeile z.B. ein tif und ein pdf gibt,
oder mehrere tif´s 001.tif; 002.tif; 003.tif (Bis zu 15 tif sind da möglich)


Ich hoffe meine Erläuterung des Problems ist eindeutig.

Für die relativen Hyperlinks hab ich schon was.
Allerdings werden hier einfach alle Dateien ausgelesen und die Hyperlinks untereinander aufgelistet.
Ich muss dann die Hyperlinks manuell den Zeilen zuordnen.

Sub HyperLink_Relative()

'************************************************************************
'* Relativer Hyperlink zu allen Dateien im Unterordner *
'* Manuelle Festlegung des Unterordners notwendig *
'************************************************************************

Dim strPath As String
Dim strFile As String
Dim i As Long

' Festlegung des Unterordners
strPath = "\documents"
' Auslesen aller Dateien des Unterordners im aktuellen Speicherpfade
strFile = Dir$(ActiveWorkbook.Path & strPath & "\*", vbNormal)

With ActiveWorkbook.ActiveSheet

Do While strFile <> ""
i = i + 1
.Cells(i + 4, 6).Value = strFile
' Relativ
.Hyperlinks.Add .Cells(i + 4, 6), "." & strPath & "\" & strFile
strFile = Dir
Loop
End With
End Sub


Ich hoffe ihr habt eine Lösung.

Danke+Gruß

Ant_oni

:)

 

Hallo ANt_oni,

statt des langen Monologes solltest du vielleicht beschreiben, was wo in der Tabelle steht und wie sich daraus der Dateiname zusammensetzt.


Gruß Sepp

 

Hallo Sepp,

sorry wenn es sich schon wie ein Monolog gelesen hat, jetzt kürzer:

Im Anhang ist ein Screenshot und auch ein Auszug aus der Excelliste. Hoffe das macht alles klarer.

Danke+Gruß
Ant_oni

 

Hallo ant_oni!

Sowas etwa:


Sub Test()
Dim Pfad
Pfad = Application.Path
MsgBox Pfad


For Each cell In Range("D2*biggrin.gif*100")
If cell.Value "" Then
cell.Offset(0, 1).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Pfad & "\" & cell.Value
End If
Next cell

End Sub


Grüße

von MD

 

Hallo Ant_oni,

ungetestet!

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub createLink()
Dim lngRow As Long, lngLast As Long, lngCol As Long
Dim strPath As String, strFile As String, strPattern As String

strPath = "\documents\"

With ActiveSheet
lngLast = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)

For lngRow = 2 To lngLast
lngCol = 5
strPattern = .Cells(lngRow, 1) & "*" & .Cells(lngRow, 2) & _
"_" & .Cells(lngRow, 3) & "_" & .Cells(lngRow, 4) & "*.*"

strFile = Dir(ThisWorkbook.Path & strPath & strPattern, vbNormal)

Do While strFile <> ""
.Hyperlinks.Add Anchor:=.Cells(lngRow, lngCol), _
Address:="." & strPath & strFile, SubAddress:="", _
TextToDisplay:=strFile

lngCol = lngCol + 1

strFile = Dir
Loop
Next
End With

End Sub


Gruß Sepp

 

Es funktioniert, noch nicht 100% wie ich es brauche, aber schon 90%, den Rest tüftel ich morgen in aller Ruhe.

Musste nur
ThisWorkbook.Path ändern in
ActiveWorkbook.Path

Danke Sepp für dieses tolle Makro!!!
Melde mich morgen nochmal.

Danke+Gruß
Ant_oni

 

Es funktioniert nun 100%, in der Gesamt-Tabelle hat was nicht gestimmt.

Ich möchte Dir Sepp, nochmal ganz herzlich danken!! *hands

Gruß
Ant_oni