AW: Excel-Dateien- Werte ersetzen
09.03.2009 13:28:25
Josef
Hallo Bernd,
' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub Festschreiben()
Dim strPath As String, strFile As String, strNewName As String, strExt As String
Dim objWB As Workbook, objWS As Worksheet
Dim intCount As Integer
On Error GoTo ErrExit
GMS
strPath = fncBrowseForFolder
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
strFile = Dir(strPath & "*.xl*")
Do While strFile <> ""
If strFile <> ThisWorkbook.Name Then
If Not strFile Like "*_Werte*" Then
intCount = intCount + 1
Set objWB = Workbooks.Open(strPath & strFile, True)
For Each objWS In objWB.Worksheets
objWS.UsedRange = objWS.UsedRange.Value
Next
strNewName = Left(strFile, InStrRev(strFile, ".")) & "_Werte"
strExt = Mid(strFile, InStrRev(strFile, "."))
objWB.SaveAs strPath & strNewName & strExt
objWB.Close True
End If
End If
strFile = Dir
Loop
If intCount > 0 Then
MsgBox "Es wurden " & CStr(intCount) & " Dateien konvertiert!"
Else
MsgBox "Es wurden keine Dateien konvertiert!"
End If
ErrExit:
With Err
If .Number <> 0 Then MsgBox .Number & vbLf & .Description, vbExclamation, "Fehler"
End With
GMS True
Set objWS = Nothing
Set objWB = Nothing
End Sub
Public Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
End Sub
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object
Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
If objFlder Is Nothing Then GoTo ErrExit
Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path
ErrExit:
Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function
Gruß Sepp