Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
900to904
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
900to904
900to904
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Teil einer rekursiven Prozedur auslagern

Teil einer rekursiven Prozedur auslagern
04.09.2007 11:10:38
Andreas
Hallo,
ich hab eine rekursive Prozedur, in welcher eine Ersetzungsschleife (Ersetzung von Teilen von Verknüpfungen) eingebaut ist. Da es sich letztendlich um viele Ersetzungen handeln wird, möchte ich das gern übersichtlicher gestalten. Als Lösungen schwebt mir da vor, die Ersetzungsschleife in ein separates Modul auszulagern oder vielleicht besser noch die Ersetzungsteile (alte und neue Version) in einer separaten Datei (Excel, txt, …) auszulagern.
Die Variante mit dem extra Modul hab ich bereits versucht, aber die funktioniert nicht, weil ich nicht weiß, welche Parameter ich mit übergeben muss und wie ich das dann schreiben muss, denn die rekursive Prozedur muss immer so weiter funktionieren.
Zu der Variante mit der separaten Datei habe ich gar keine Idee, wie das umgesetzt werden könnte.
Kann mir vielleicht jemand weiter helfen?
Hier noch die rekursive Prozedur:

Public Sub xDirFile(xpath As String)
Dim xa As Long
Dim xDir As String
ReDim xt(0) As String
Dim xi As Long
Dim xAc As String
Dim wb As Workbook
Dim aLinks
Dim i As Integer
Dim newlink As String
' Zulassen von allen Formen von Dateien
' schreibgeschützte, versteckte, Systemdateien, Verzeichnisse, Ordner, ...
xDir = Dir(xpath & "\*.*", vbNormal Or vbReadOnly Or vbHidden _
Or vbSystem Or vbVolume Or vbDirectory Or vbArchive)
xa = 0
If Len(xDir) > 0 Then
xt(0) = xDir
End If
Do While Len(xDir) > 0
xDir = Dir
If Len(xDir) > 0 And Not xDir = "." And Not xDir = ".." Then
xa& = xa& + 1
ReDim Preserve xt(xa)
xt(xa) = xDir
End If
Loop
On Error GoTo Schleife
For xi& = 0 To xa&
If Len(xt(xi)) = 0 Then
Exit For
ElseIf Not xt(xi) = "." And Not xt(xi) = ".." Then
If Len(Dir$(xpath$ & "\" & xt$(xi&), vbNormal Or vbReadOnly Or vbHidden _
Or vbSystem Or vbVolume Or vbDirectory Or vbArchive)) > 0 Then
If Not (GetAttr(xpath & "\" & xt(xi)) And vbDirectory) = vbDirectory Then
'wenn Exceldatei
If UCase(Right(xt(xi), 3)) = "XLS" Then
'Debug.Print xpath & "\" & xt(xi)
' die "0" bedeutet, dass die Frage nach der Aktualisierung
' von Verlinkungen verneint wird
Set wb = Workbooks.Open(xpath & "\" & xt(xi), 0)
aLinks = wb.LinkSources(xlExcelLinks)
If Not IsEmpty(aLinks) Then
' Zählvariable -> kann weggelassen werden
z = z + 1
For i = 1 To UBound(aLinks)
' Schleife, die für die Ersetzungen zuständig ist
' Hier müssen alle zu ersetzenden Verknüpfungen aufgelistet sein
' --> neuer Verknüpfungsanfang muss demenstprechend ebenfalls angegeben  _
werden
If Left(aLinks(i), 21) = "D:\Berichte\2005\alt\" Then
newlink = Replace(aLinks(i), "I:\Projekt\alt\2005\", _
"D:\neu\Berichte\2005\---\", , , vbTextCompare)
wb.ChangeLink aLinks(i), newlink, xlLinkTypeExcelLinks
wb.Save
ElseIf Left(aLinks(i), 21) = "D:\Berichte\2005\neu\" Then
newlink = Replace(aLinks(i), "I:\Projekt\neu\2005\", _
"D:\neu\Berichte\2005\---\", , , vbTextCompare)
wb.ChangeLink aLinks(i), newlink, xlLinkTypeExcelLinks
wb.Save
ElseIf Left(aLinks(i), 21) = "D:\Berichte\2006\alt\" Then
newlink = Replace(aLinks(i), "I:\Projekt\alt\2006\", _
"D:\neu\Berichte\2006\---\", , , vbTextCompare)
wb.ChangeLink aLinks(i), newlink, xlLinkTypeExcelLinks
wb.Save
End If
Next i
End If
wb.Close savechanges:=False
Set wb = Nothing
End If
Else
Call xDirFile(xpath & "\" & xt(xi))
End If
End If
End If
Schleife:
Next xi&
On Error GoTo 0
End Sub


Danke und Gruss
Andreas

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Teil einer rekursiven Prozedur auslagern
07.09.2007 09:18:44
Gerd
Hallo Andreas,
Schleife in anderes Modul auslagern, ungetestet.
...................................
If Not IsEmpty(aLinks) Then
' Zählvariable -> kann weggelassen werden
z = z + 1
NEUVERLINKEN aLinks, wb
End If
.........................................

Public Function NEUVERLINKEN(aLinks, wb)
Dim i As Long
For i = 1 To UBound(aLinks)
' Schleife, die für die Ersetzungen zuständig ist
' Hier müssen alle zu ersetzenden Verknüpfungen aufgelistet sein
' --> neuer Verknüpfungsanfang muss demenstprechend ebenfalls  _
angegeben _
werden
If Left(aLinks(i), 21) = "D:\Berichte\2005\alt\" Then
newlink = Replace(aLinks(i), "I:\Projekt\alt\2005\", _
"D:\neu\Berichte\2005\---\", , , vbTextCompare)
wb.ChangeLink aLinks(i), newlink, xlLinkTypeExcelLinks
wb.Save
ElseIf Left(aLinks(i), 21) = "D:\Berichte\2005\neu\" Then
newlink = Replace(aLinks(i), "I:\Projekt\neu\2005\", _
"D:\neu\Berichte\2005\---\", , , vbTextCompare)
wb.ChangeLink aLinks(i), newlink, xlLinkTypeExcelLinks
wb.Save
ElseIf Left(aLinks(i), 21) = "D:\Berichte\2006\alt\" Then
newlink = Replace(aLinks(i), "I:\Projekt\alt\2006\", _
"D:\neu\Berichte\2006\---\", , , vbTextCompare)
wb.ChangeLink aLinks(i), newlink, xlLinkTypeExcelLinks
wb.Save
End If
Next i
End Function


Gruß Gerd

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige