Hyperlink
16.03.2009 14:02:48
Baumpaul1
ich habe mit hilfe von Forumusern eine VBA Lösung im Einsatz, die mir 6 Tabellen aus verschiedenen Dateien im Netztwerk in eine Datei mit 6 Tabellen kopiert und aktualisiert.
Nun stellt sich das Problem, dass die Quelldateien Hyperlinks enthalten und sich bei der Aktualisierung in der Zieldatei umgeschreiben. Die Hyperlinks sind mit komplettem Serverpfad eingefügt, also eigentlich statisch, oder? kann man dies irgendwie Verhindern?
anbei der Code:
Sub BlattInhaltKopieren(strVerzeichnis$, strQuelle$, varSheet, wksZiel As Worksheet)
Dim wbQuelle As Workbook, wksQuelle As Worksheet, bolOpen As Boolean
Dim intFehler As Integer
'Alles(Inhalte + Formate + Kommentare + Gliederung) in Spalten A bis N löschen
On Error GoTo Fehler
intFehler = 1
With wksZiel.Range("A1:N1")
.EntireColumn.Clear
End With
'Prüfen ob Quelle schon geöffnet
intFehler = 0
If fncDateiOpen(strQuelle) = True Then
Set wbQuelle = Workbooks(strQuelle)
bolOpen = True
Else
intFehler = 2
Set wbQuelle = Workbooks.Open(Filename:=strVerzeichnis & "\" & strQuelle, ReadOnly:=True)
bolOpen = False
End If
'Quelltabelle setzen
intFehler = 3
Set wksQuelle = wbQuelle.Worksheets(varSheet)
intFehler = 4
With wksQuelle
.Range("A1:N1").EntireColumn.Copy Destination:=wksZiel.Cells(1, 1)
End With
intFehler = 0
Application.CutCopyMode = False
If bolOpen = False Then
wbQuelle.Close savechanges:=False
End If
Fehler:
With Err
If .Number 0 Then
Select Case intFehler
Case 1
MsgBox "Fehler-Nr. " & Err.Number & vbLf & .Description & vbLf & vbLf _
& "Problem beim Löschen in Zieltabelle """ & wksZiel.Name & """"
Case 2
MsgBox "Fehler-Nr. " & Err.Number & vbLf & .Description & vbLf & vbLf _
& "Problem beim Öffnen von Datei """ & strQuelle & """"
Case 3
MsgBox "Fehler-Nr. " & Err.Number & vbLf & .Description & vbLf & vbLf _
& "Problem beim Setzen der Quelltabelle """ & strQuelle & """"
Case 4
MsgBox "Fehler-Nr. " & Err.Number & vbLf & .Description & vbLf & vbLf _
& "Problem beim Kopieren der Daten aus Quelle nach Ziel """ & strQuelle & """"
Case Else
MsgBox "Fehler-Nr. " & Err.Number & vbLf & .Description & vbLf & vbLf _
& "Bitte korrekte Schreibweise von Blatt und Dateinamen prüfen!"
End Select
Application.ScreenUpdating = True
End If
End With
End Sub
Sub Daten_Aktualisieren()
Dim wbZiel As Workbook, intI As Integer
Dim strPfad$, strDatei$, strBlattQ, strBlattZ$
On Error GoTo Fehler
Application.ScreenUpdating = False
Set wbZiel = ActiveWorkbook
strPfad = "\\Fileserver\fe1-allg\Controlling\Controlling SMD-Linien"
For intI = 1 To 6
strDatei = "Controlling SMD Linie " & intI & " .xls"
strBlattQ = "Controlling SMD Linie " & intI
strBlattZ = strBlattQ
Call BlattInhaltKopieren(strVerzeichnis:=strPfad, strQuelle:=strDatei, _
varSheet:=strBlattQ, wksZiel:=wbZiel.Worksheets(strBlattZ))
Next
Fehler:
With Err
If .Number 0 Then
MsgBox "Fehler-Nr. " & Err.Number & vbLf & .Description
End If
End With
Application.ScreenUpdating = True
End Sub
Gruss
Baumpaul1