Excel to txt-files

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub DatenEinlesen() Dim wkbNeu As Workbook, wksDataSheet As Worksheet, fs As FileSearch Dim F As Long Application.ScreenUpdating = False Workbooks.Add Set wkbNeu = ActiveWorkbook Set fs = Application.FileSearch 'MsgBox Dir("Y:\AusDateiAuslesen\Daten\/nul") 'MsgBox Dir("H:\/nul") With fs .NewSearch .LookIn = "Y:\AusDateiAuslesen\Daten" .SearchSubFolders = True .Filename = "*.xls" If .Execute() > 0 Then For F = 1 To .FoundFiles.Count wkbNeu.Sheets(1).Cells(F, 1) = .FoundFiles(F) Next F Else MsgBox "There were no files found." End If End With wkbNeu.Activate Application.ScreenUpdating = True End Sub

Sub ExcelToTxt() Dim meDatei As Workbook Dim FName$, NeuerPfadName$ On Error GoTo goError FName = Dir("C:\Meine ExcelDateien\*.xls") 'Pfad angeben EventAusAn False While FName "" If FName ThisWorkbook.Name Then Set meDatei = Workbooks.Open(Filename:=FName) meDatei.Sheets(1).Select NeuerPfadName = Replace(meDatei.FullName, ".xls", ".txt") meDatei.SaveAs Filename:=NeuerPfadName, FileFormat:= _ xlText, CreateBackup:=False meDatei.Close End If FName = Dir() Wend goError: EventAusAn End Sub

Sub EventAusAn(Optional Zustand As Boolean = True) Static ZustandAlt As Long If Zustand = False Then ZustandAlt = Application.Calculation With Application .EnableEvents = Zustand .ScreenUpdating = Zustand .DisplayAlerts = Zustand .Calculation = IIf(Zustand = True, ZustandAlt, xlCalculationManual) End With End Sub

Hallo Forum,
der Vollständigkeit halber ist hier meine Endversion. Funktioniert prima.


Sub Excel_To_Txt()
'---Prozedur öffnet sämtliche Excel-files im Arbeitspfad und speichert das
'---jeweils 1te Worksheet als txt Datei. (Trennzeichen: Tab)
'--- -> funktioniert
Dim gobjExcel As Excel.Application
Dim gobjWb As Excel.Workbook
Dim strPfad As String, strDatei As String, strPathAndTxtName As String, arrStrPathAndExcelfiles( _
) As String
Dim i As Integer
'---Lesen des Arbeits-Pfades
strPfad = Range("c_Path").Value
If Right(strPfad, 1)  "\" Then
strPfad = strPfad & "\"
End If
'---Lesen der Excelfilenamen im Arbeitspfad
ReDim arrStrPathAndExcelfiles(1 To 1000)
i = 0
strDatei = Dir$(strPfad & "*.xls")
Do While strDatei  ""
i = i + 1
arrStrPathAndExcelfiles(i) = strPfad & strDatei
strDatei = Dir$()
Loop
ReDim Preserve arrStrPathAndExcelfiles(1 To i)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set gobjExcel = New Excel.Application
'--Sämtliche Excel-files als txt-files speichern----start
For i = 1 To UBound(arrStrPathAndExcelfiles)
Set gobjWb = Workbooks.Open(arrStrPathAndExcelfiles(i))
strPathAndTxtName = Replace(gobjWb.FullName, ".xls", ".txt")
gobjWb.Worksheets(1).Select
gobjWb.SaveAs Filename:=strPathAndTxtName, FileFormat:=xlText, CreateBackup:=False
gobjWb.Close savechanges:=False
Next i
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
Set gobjExcel = Nothing
Set gobjWb = Nothing
MsgBox "Ready"
End Sub

Gruß,
Andreas B.

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread