Komplexes Problem

Hallo beisammen,
ich habe ein sehr komplexes Problem das mithilfe eines Makros gelöst werden soll. Ich beiße mir da grade die Zähne aus...
Problemstellung:
Ich habe sehr viele Excel-Dokumente, diese sind immer nach dem gleichen Muster aufgebaut. In der Spalte B befindet sich in jeder Zelle (außer der ersten) ein Hyperlink, dieser verweist auf eine XML-Datei innerhalb eines Intranets einer Firma (ich selbst befinde mich innerhalb dieses Netzwerks, dh. keine Probleme mit Zugriffsrechten). Die Datei auf die der Hyperlink zeigt soll nun lokal auf meine Festplatte kopiert werden, und sodann der Link in der Exceldatei auf diese lokale Datei umgeschrieben werden. Die lokale Datei soll dann im Unterverzeichnis "proto_xsl" gespeichet werden.
Hat jemand eine Idee?
Viele Grüße und ein schönes Wochenende
Manfred Schreistetter

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Komplexes Problem

11.02.2007 11:20:14

fcs

AW: Komplexes Problem

13.02.2007 17:14:02

Manfred

13.02.2007 18:01:41

Hallo Manfred,
folgendes Makro funktioniert bei mir auf lokalen Laufwerken und Verzeichnissen. Ich weiss nicht, ob die FileCopy-Methode auch mit Intranet-Pfaden/Verzeichnissen klarkommt.
Gruss
Franz


Sub HyperlinksNachLokalKopieren()
' Erstellt mit Excel 97
Dim wb As Workbook, strWb, j As Integer, Zelle As Range, wks As Worksheet
Dim VerzZiel As String, Datei As String, Quelle As String, wbHyper As Workbook
VerzZiel = "C:\Test\proto_xsl" 'Zielverzeichnis für Kopien
Do
'Arbeitsmappe(n) auswählen, die abgearbeitet werden sollen, _
Mehrfachauswahl im Dialog ist möglich
strWb = Application.GetOpenFilename(Filefilter:="Excel (*.xls), *.xls", _
Title:="Bitte Datei(en) für Bearbeitung auswählen, Abbrechen beendet das Makro", _
MultiSelect:=True)
If Not IsArray(strWb) Then Exit Sub
For j = LBound(strWb) To UBound(strWb)
Set wb = Workbooks.Open(FileName:=strWb(j))
Application.ScreenUpdating = False
Set wks = wb.Worksheets(1)
'Hyperlinks in Spalte B abarbeiten
For Zeile = 2 To wks.Cells(wks.Rows.Count, 2).End(xlUp).Row
Set Zelle = wks.Cells(Zeile, 2)
If Zelle.Hyperlinks.Count > 0 Then
Quelle = Zelle.Hyperlinks(1).Address 'Hyperlinkaddresse
Datei = Right(Quelle, Len(Quelle) - VonRechts(Quelle, "\")) 'Dateiname abtrennen
VBA.FileCopy Quelle, VerzZiel & "\" & Datei
Zelle.Hyperlinks(1).Address = VerzZiel & "\" & Datei 'Neuen Hyperlink zuweisen
Zelle.Value = VerzZiel & "\" & Datei 'oder = Datei  'Zellinhalt anpassen
End If
Next
Application.ScreenUpdating = True
MsgBox "Datei " & strWb(j) & " bearbeitet"
wb.Save
wb.Close
Next j
Loop
End Sub
Function VonRechts(ByVal TextLang As String, Trennzeichen As String, Optional Zeichen As Integer = 1) As Integer
'Ermittelt die Position eines Zeichens im Text von Rechts (nur für Excel97)
'Bei neueren Excel-Versionen kann die entsprechende Funktion verwendet werden
For VonRechts = Len(TextLang) - Zeichen + 1 To 1 Step -1
If Mid(TextLang, VonRechts, 1) = Trennzeichen Then Exit Function
Next
End Function

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread