AW: per makro xlsx in xls konvertieren
11.06.2008 18:44:00
Tino
Hallo,
hilft Dir dieser Code um an Dein Ziel zu kommen?
Auf eine Fehlerbehandlung habe ich noch verzichtet, bei mir hat es funktioniert!
'Benötig den Verweis auf > Microsoft Scripting Runtime
Datei mit diesem Makro, muss sich in dem Ordner befinden wo Deine Dateien sind!
Achtung: *.xlsm Datei wird gelöscht!!!!!!!!
Option Explicit
'Benötig den Verweis auf > Microsoft Scripting Runtime
Dim FehlerDatei As String, AltZustand As Long, AnzahlKonvert As Long
Sub Start()
eventsAusAn (False)
ListFilesInFolder ThisWorkbook.Path, False, ".xlsm" 'True = mit Unterordner
eventsAusAn
MsgBox "Es wurden " & AnzahlKonvert & " Dateien konvertiert", vbInformation
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean, Optional _
DateiFormat As String)
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
For Each FileItem In SourceFolder.Files
If (InStr(FileItem.Name, DateiFormat) > 0) And (InStr(FileItem.Name, ThisWorkbook.Name) _
_
= 0) Then
StartKill (FileItem.Path)
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Sub StartKill(strFileName As String)
Dim strDateiName As String, neuDateiFull As String
Application.DisplayAlerts = False
strDateiName = Right$(strFileName, Len(strFileName) - InStrRev(strFileName, "\"))
Workbooks.Open (strFileName)
neuDateiFull = Replace(strFileName, "xlsm", "xls", , Len(strFileName) - 5)
'speichern als xls
ActiveWorkbook.SaveAs Filename:=neuDateiFull, FileFormat:=xlExcel8 _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
'Lösche alte Datei
Kill strFileName
Workbooks(Right$(neuDatei, Len(neuDatei) - InStrRev(neuDatei, "\"))).Close
AnzahlKonver = AnzahlKonver + 1
End Sub
Function eventsAusAn(Optional Zustand As Boolean = True)
If Zustand = False Then AltZustand = Application.Calculation
With Application
.ScreenUpdating = Zustand
.Calculation = IIf(Zustand = False, xlCalculationManual, AltZustand)
.EnableEvents = Zustand
End With
End Function
Gruß Tino
www.tinomargit.com