AW: Datenänderung
19.12.2013 09:47:05
UweD
Hallo
ich hab mal ein bestehendes Makro (Irgendo mal aus dem Netz geladen) auf deine Belange abgeändert.
Sub Files_Read()
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
Dim strEX As String
On Error GoTo Fehler
Application.ScreenUpdating = False
strEX = "*.xls*"
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDir = "C:\Temp\"
strDir = IIf(Right(strDir, 1) "\", strDir & "\", strDir)
Set objDir = objFSO.getfolder(strDir)
dirInfo objDir, strEX, True ' Mit Unterordner
Fehler:
If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
Dim varTMP As Variant
Dim strNEX As String
Dim strNew As String
strNEX = ".txt"
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName Then
If varTMP.Name ThisWorkbook.Name Then
If Left(varTMP.Name, 1) "~" Then 'keine temporäre Dateien
Workbooks.Open Filename:=varTMP.Path
strNew = Left(varTMP.Path, InStrRev(varTMP.Path, ".") - 1) & strNEX
ActiveWorkbook.SaveAs Filename:=strNew, FileFormat:=xlCSV, _
CreateBackup:=False
ActiveWindow.Close savechanges:=False
End If
End If
End If
Next varTMP
If blnTMP = True Then 'Unterordner
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, blnTMP
Next varTMP
End If
End Sub
Gruß UweD