Ergänzung !!! Laufwerksbuchstaben in VBA
28.09.2005 15:43:58
Heiko
Hallo Denis,
bevor die Rückfrage kommt, was tun bei Fehlermeldung 1024 hier ein neuer Code, andere kleine Fehler habe ich auch gleich behoben. Also VBA_Code_Ersetzen komplett ersetzen.
Function VBA_Code_Ersetzen()
Dim strFolder As String, strCode As String, strSuchText As String, strErsetzText As String
Dim lngI As Long, lngCounter As Long
Dim vbc As Object
strSuchText = Sheets("Master").Range("B1").Text
strErsetzText = Sheets("Master").Range("B2").Text
On Error Resume Next
ChDrive Sheets("Tabelle2").Range("B1")
ChDir Sheets("Tabelle2").Range("B2")
If Err.Number <> 0 Then
ChDrive Left(ThisWorkbook.Path, 2)
ChDir ThisWorkbook.Path
End If
Err.Clear
On Error GoTo 0
strFolder = Sheets("Tabelle2").Range("B3")
strFolder = OrdnerWaehlen("Bitte wählen Sie einen Pfad in dem die EXCEL Files sind wo Suchen/Ersetzen durchgeführt werden soll !", strFolder)
If strFolder = "" Then
MsgBox "Sie haben keinen Pfad ausgewählt!", vbInformation
Exit Function
End If
Sheets("Tabelle2").Range("B3") = strFolder
ChDrive Left(strFolder, 2)
ChDir strFolder
With Application.FileSearch
.NewSearch
.LookIn = strFolder
.SearchSubFolders = True
.Filename = "*.xls"
.Execute
If .FoundFiles.Count = 0 Then
MsgBox "Im angegebenen Laufwerk wurden keine EXCEL Dateien gefunden !", vbInformation
Exit Function
End If
Application.ScreenUpdating = False
On Error GoTo Errorhandler
For lngI = 1 To .FoundFiles.Count
Application.StatusBar = "Datei " & lngI & " von " & .FoundFiles.Count & ". " & .FoundFiles(lngI) & " wird bearbeitet"
Workbooks.Open .FoundFiles(lngI)
With ActiveWorkbook.VBProject
For Each vbc In .VBComponents
With .VBComponents(vbc.Name).CodeModule
For lngCounter = 1 To .CountOfLines
strCode = .Lines(lngCounter, 1)
.ReplaceLine lngCounter, Replace(strCode, strSuchText, strErsetzText)
Next lngCounter
End With
Next vbc
End With
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.StatusBar = False
Next lngI
End With
Application.ScreenUpdating = True
MsgBox "Fertig !", vbInformation
Exit Function
' Bei Fehlernummer 1004, diese Meldung ausgeben.
Errorhandler:
Application.ScreenUpdating = True
Application.StatusBar = False
If Err.Number = 1004 Then
MsgBox "Das Ersetzen des VBA Codes ist fehlgeschlagen!" & vbCr & _
"Bitte überprüfen Sie folgende Einstellung! " & vbCr & _
"EXTRAS -> MAKRO -> SICHERHEIT -> Vertrauenwürdige Quellen." & vbCr & _
"'Zugriff auf Visual Basic Projekt vertrauen' muss aktiviert sein! ", vbCritical, _
" Meldung vom Makro VBACodeErsetzen"
Else
MsgBox "Err.Number = " & Err.Number & ". " & Err.Description, vbCritical
End If
End Function
Gruß Heiko
PS: Rückmeldung wäre nett !