Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
972to976
972to976
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

alle *.txt Files in einem Ordner öffnen und ...

Forumthread: alle *.txt Files in einem Ordner öffnen und ...

alle *.txt Files in einem Ordner öffnen und ...
06.05.2008 15:02:02
Peter
... einen Makro (in pers. Makrovorlage), der mit Ctl-Shift-J aufgerufen werden kann, ablaufen lassen.
Guten Tag
Mit nachfolgendem Makro, der in der PERSONL.xls abgespeichert ist und mit Ctl-Shift-J aufgerufen werden kann, bearbeite ich eine grosse Menge von txt-Files. Nach der Bearbeitung wird die Datei jeweils als "*.xls File gespeichert und geschlossen.
Nun möchte ich das Makro erweitern, so dass alle *.txt-Files, die in einem bestimmten Ordner vorhanden sind, der Reihe nach geöffnet werden und dann die Bearbeitung durchgeführt wird.
Fragen:
- Wie kann ich ein Dialog kreieren, dass als allererstes der Pfad, des entsprechenden Ordners ausgewählt werden kann
- und wie kann ich anschliessend die einzelnen *.txt Dateien öffnen (*.xls -Dateien sollen ignoriert werden) und meinen bisherigen Code laufen lassen?
Danke für jede Hilfe.
Gruss, Peter

Sub AAStammdatenFile()
' Tastenkombination: Strg+Umschalt+J
Dim strName As String
Dim strPath As String
Dim strFull As String
strName = ActiveWorkbook.Name
strPath = ActiveWorkbook.Path
strFull = strPath & "\" & strName
strFull = WorksheetFunction.Substitute(strFull, ".txt", ".xls")
'MsgBox strFull
Application.Goto Reference:="C1"
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(20, 1), Array(26, 1), Array(47, 1), Array(67, 1), _
Array(76, 1), Array(87, 1), Array(109, 1), Array(136, 1), Array(152, 1)), _
TrailingMinusNumbers:=True
Columns("D:D").EntireColumn.AutoFit
ActiveWorkbook.Sheets(1).Name = "ValStammDaten"
ActiveWorkbook.SaveAs Filename:=strFull _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWindow.Close
End Sub


Anzeige

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: alle *.txt Files in einem Ordner öffnen und ...
06.05.2008 15:14:37
Rudi
Hallo,
so:

Option Explicit
Public intCalculation As Integer
Sub TXT2XLS()
'Alle .txt (Trennzeichen Tab) eines Ordners in .xls umwandeln
Dim oFS As Object, oFolder As Object, oFile As Object
Dim strFolder As String
Dim strTxt As String, myArr, lngL As Long, WKS As Worksheet, iFREE As Integer
With Application.FileDialog(4)
.InitialFileName = "n:\"
.InitialView = 2
.Title = "Bitte einen Ordner wählen"
If .Show = -1 Then
strFolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
On Error GoTo FEHLER
DoEvents
GetMoreSpeed
Set oFS = CreateObject("scripting.filesystemobject")
Set oFolder = oFS.getfolder(strFolder)
iFREE = FreeFile
For Each oFile In oFolder.Files
If oFile.Name Like "*.txt" Then
lngL = 1
Open oFile For Input As iFREE
Set WKS = Workbooks.Add(1).Sheets(1)
Do Until EOF(iFREE)
Line Input #iFREE, strTxt
myArr = Split(strTxt, vbTab)  'Trennzeichen ; anpassen
With WKS
.Range(.Cells(lngL, 1), .Cells(lngL, UBound(myArr) + 1)) = myArr
End With
lngL = lngL + 1
Erase myArr
Loop
Close #iFREE
End If
With WKS.Parent
.SaveAs Replace(oFile, ".txt", ".xls"), xlWorkbookNormal
.Close False
End With
Set WKS = Nothing
Next oFile
AUFRAEUMEN:
Set oFile = Nothing
Set oFolder = Nothing
Set oFS = Nothing
GetMoreSpeed False
Exit Sub
FEHLER:
If Err.Number Then
MsgBox "Fehler!" & vbLf & Err.Description
Err.Clear
Resume AUFRAEUMEN
End If
End Sub
Sub GetMoreSpeed(Optional ByVal Modus As Boolean = True)
If Modus = True Then intCalculation = Application.Calculation
With Application
.ScreenUpdating = Not Modus
.EnableEvents = Not Modus
.Calculation = IIf(Modus = True, xlManual, intCalculation)
.Cursor = IIf(Modus = True, 2, -4143)
End With
End Sub


Gruß
Rudi

Anzeige
Frage eines 'Unbeteiligten'
06.05.2008 15:26:00
David
Hallo Rudi,
da ich mich ja auch mal immer wieder hier weiterbilde, habe ich mal eine Frage zu diesem Makro. Was passiert in diesem Modul "GetMoreSpeed"? Die ersten beiden Zeilen nach .WITH APPLICATION entsprechen vermutlich den Befehlen "ScreenUpdating = True/False" und ApplicationEvents = True/False" (so ungefähr) - aber was machen die beiden anderen Befehle?
Übrigens:
Wow, wie lange brauchst du für solch ein Makro? Oder hast du sowas "rumliegen"? Finde ich echt toll, wenn man anderen mit so viel Mühe (oder ist das keine solche für dich?) ohne Weiteres weiterhilft!
Gruß
David

Anzeige
AW: Frage eines 'Unbeteiligten'
06.05.2008 15:30:54
Rudi
Hallo,

aber was machen die beiden anderen Befehle?


1. den Berechnungsmodus auf manuell und wieder zurückstellen
2. den Cursor als Sanduhr darstellen.


Oder hast du sowas "rumliegen"?


Aber sicher.
Gruß
Rudi

Anzeige
AW: alle *.txt Files in einem Ordner öffnen und ...
06.05.2008 15:27:05
Bertram
Hallo Rudi,
kann das sein, das dein Code mit Excel 9 nicht funktioniert?
Gruß
Bertram

AW: alle *.txt Files in einem Ordner öffnen und ...
06.05.2008 15:37:03
Fred
Hi,
den Filedialog gibt es ab Excel 10.
mfg Fred

AW: alle *.txt Files in einem Ordner öffnen und ...
06.05.2008 15:37:17
Rudi
Hallo
das hier geht erst ab 2000:

With Application.FileDialog(4)
.InitialFileName = "n:\"
.InitialView = 2
.Title = "Bitte einen Ordner wählen"
If .Show = -1 Then
strFolder = .SelectedItems(1)
Else
Exit Sub
End If
End With


in ein Modul:


Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim R As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
R = SHGetPathFromIDList(ByVal x, ByVal Path)
If R Then
pos = InStr(Path, Chr$(0))
GetDirectory = Left(Path, pos - 1)
Else
GetDirectory = ""
End If
End Function


und im Code die File-Dialog-Sequenz durch


strFolder=GetDirectory


ersetzen, dann sollte es auch in XL97 funktionieren.
Gruß
Rudi

Anzeige
AW: alle *.txt Files in einem Ordner öffnen und ...
06.05.2008 16:02:09
Bertram
Hallo Rudi,
funktioniert einwandfrei.
Habe allerdings den Teil

With WKS.Parent
.SaveAs Replace(oFile, ".txt", ".xls"), xlWorkbookNormal
.Close False
End With
Set WKS = Nothing


aus deinem vorherigen Post vor das End If gepackt, sonst gibt's nen Fehler. Ist das ok so?
Gruß
Bertram

Anzeige
AW: alle *.txt Files in einem Ordner öffnen und ...
06.05.2008 16:36:00
Peter
Hallo Rudi
Vielen Dank. Ich habe versucht, den Code auf meine Verhältnisse zu adaptieren.
Da ich in meinen Files verschiedene Tabulatoren setzen muss, habe ich ein separates Makro geschrieben, das mir die spezifische Umwandlung (Text in Spalten) bewerkstelligt. Deshalb habe ich verschiedene Zeilen deines Makro (sind es wohl die richtigen?) auskommentiert und anstelle dessen meinen Makro aufgerufen (mit Call AAStammdatenFile).
Im Moment scheint der Code ein Problem in der Zeile
.Calculation = IIf(Modus = True, xlManual, intCalculation)
zu haben - da springt er immer zur Fehlerbehandlung.
Da bin ich leider am Ende meines Lateins.
Kannst du mir allenfalls weiterhelfen?
- habe ich die richtigen Zeilen auskommentiert?
- woran könnte das Problem liegen, dass der Code bei .Calculation zur Fehlerbehandlung springt?
Danke für jede Hilfe.
Gruss, Peter
Option Explicit
Public intCalculation As Integer

Sub TXT2XLS()
'Alle .txt (Trennzeichen Tab) eines Ordners in .xls umwandeln
Dim oFS As Object, oFolder As Object, oFile As Object
Dim strFolder As String
Dim strTxt As String, myArr, lngL As Long, WKS As Worksheet, iFREE As Integer
With Application.FileDialog(4)
.InitialFileName = "H:\"
.InitialView = 2
.Title = "Bitte einen Ordner wählen"
If .Show = -1 Then
strFolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
On Error GoTo FEHLER
DoEvents
GetMoreSpeed
Set oFS = CreateObject("scripting.filesystemobject")
Set oFolder = oFS.getfolder(strFolder)
iFREE = FreeFile
For Each oFile In oFolder.Files
If oFile.Name Like "*.txt" Then
lngL = 1
Open oFile For Input As iFREE
'''''''               Set WKS = Workbooks.Add(1).Sheets(1)
'''''''               Do Until EOF(iFREE)
'''''''                  Line Input #iFREE, strTxt
'''''''                  myArr = Split(strTxt, vbTab)  'Trennzeichen ; anpassen
'''''''                  With WKS
'''''''                     .Range(.Cells(lngL, 1), .Cells(lngL, UBound(myArr) + 1)) = myArr
'''''''                  End With
'''''''                  lngL = lngL + 1
'''''''                  Erase myArr
'''''''               Loop
'''''''               Close #iFREE
End If
Call AAStammdatenFile
'''''''            With WKS.Parent
'''''''               .SaveAs Replace(oFile, ".txt", ".xls"), xlWorkbookNormal
'''''''               .Close False
'''''''            End With
Set WKS = Nothing
Next oFile
AUFRAEUMEN:
Set oFile = Nothing
Set oFolder = Nothing
Set oFS = Nothing
GetMoreSpeed False
Exit Sub
FEHLER:
If Err.Number Then
MsgBox "Fehler!" & vbLf & Err.Description
Err.Clear
Resume AUFRAEUMEN
End If
End Sub




Sub GetMoreSpeed(Optional ByVal Modus As Boolean = True)
If Modus = True Then intCalculation = Application.Calculation
With Application
.ScreenUpdating = Not Modus
.EnableEvents = Not Modus
.Calculation = IIf(Modus = True, xlManual, intCalculation)
.Cursor = IIf(Modus = True, 2, -4143)
End With
End Sub




Sub AAStammdatenFile()
' Tastenkombination: Strg+Umschalt+J
Dim strName As String
Dim strPath As String
Dim strFull As String
strName = ActiveWorkbook.Name
strPath = ActiveWorkbook.Path
strFull = strPath & "\" & strName
strFull = WorksheetFunction.Substitute(strFull, ".txt", ".xls")
'MsgBox strFull
Application.Goto Reference:="C1"
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(20, 1), Array(26, 1), Array(47, 1), Array(67, 1), _
Array(76, 1), Array(87, 1), Array(109, 1), Array(136, 1), Array(152, 1)), _
TrailingMinusNumbers:=True
Columns("D:D").EntireColumn.AutoFit
ActiveWorkbook.Sheets(1).Name = "ValStammDaten"
ActiveWorkbook.SaveAs Filename:=strFull _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWindow.Close
End Sub


Anzeige
AW: alle *.txt Files in einem Ordner öffnen und ...
06.05.2008 17:18:00
Rudi
Hallo,
evtl. so:

Option Explicit
Dim intCalculation As Integer
Sub TXT2XLS()
'Alle .txt (Trennzeichen Tab) eines Ordners in .xls umwandeln
Dim oFS As Object, oFolder As Object, oFile As Object
Dim strFolder As String
Dim WKB As Workbook
With Application.FileDialog(4)
.InitialFileName = "H:\"
.InitialView = 2
.Title = "Bitte einen Ordner wählen"
If .Show = -1 Then
strFolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
On Error GoTo FEHLER
DoEvents
GetMoreSpeed
Set oFS = CreateObject("scripting.filesystemobject")
Set oFolder = oFS.getfolder(strFolder)
For Each oFile In oFolder.Files
If oFile.Name Like "*.txt" Then
Set WKB = Workbooks.Open(oFile)
Call AAStammdatenFile(WKB)
End If
Set WKB = Nothing
Next oFile
AUFRAEUMEN:
Set oFile = Nothing
Set oFolder = Nothing
Set oFS = Nothing
GetMoreSpeed False
Exit Sub
FEHLER:
If Err.Number Then
MsgBox "Fehler!" & vbLf & Err.Description
Err.Clear
Resume AUFRAEUMEN
End If
End Sub
Sub GetMoreSpeed(Optional ByVal Modus As Boolean = True)
If Modus = True Then intCalculation = Application.Calculation
With Application
.ScreenUpdating = Not Modus
.EnableEvents = Not Modus
.Calculation = IIf(Modus = True, xlManual, intCalculation)
.Cursor = IIf(Modus = True, 2, -4143)
End With
End Sub
Sub AAStammdatenFile(WKB As Workbook)
' Tastenkombination: Strg+Umschalt+J
Dim strFull As String
strFull = WKB.FullName
strFull = WorksheetFunction.Substitute(strFull, ".txt", ".xls")
Application.Goto Reference:="C1"
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(20, 1), Array(26, 1), Array(47, 1), Array(67, 1), _
Array(76, 1), Array(87, 1), Array(109, 1), Array(136, 1), Array(152, 1)), _
TrailingMinusNumbers:=True
Columns("D:D").EntireColumn.AutoFit
WKB.Sheets(1).Name = "ValStammDaten"
WKB.SaveAs Filename:=strFull _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
WKB.Close
End Sub


Ich kenn ja deine Textfiles nicht.
Gruß
Rudi

Anzeige
AW: alle *.txt Files in einem Ordner öffnen und ...
07.05.2008 08:22:09
Peter
Hallo Rudi
So klappt es prima.
A propos "Ich kenne ja deine Textfiles nicht.": Spielt ja hier keine Rolle, da nun dein Code, die Files öffnet (was natürlich die Mammutarbeit ist) - die Bearbeitung macht dann der Aufruf des Makros AAStammdatenFile.
Nochmals vielen Dank!
Peter

Anzeige
AW: alle *.txt Files in einem Ordner öffnen und ...
07.05.2008 08:40:00
Peter
Hallo Rudi
Kleiner Nachtrag resp. Nachfrage.
Grundsätzlich kann ich ja dieses Marko starten, wenn keine xls-Datei offen ist. Dann habe ich jedoch ein Problem mit GetMoreSpeed und zwar mit
If Modus = True Then intCalculation = Application.Calculation
da hier ein Fehler entsteht.
Ist die Lösung einfach, das mindestens eine Datei offen sein muss, wenn dieser Makro aufgerufen wird?
Gruss, Peter

Sub GetMoreSpeed(Optional ByVal Modus As Boolean = True)
If Modus = True Then intCalculation = Application.Calculation
With Application
.ScreenUpdating = Not Modus
.EnableEvents = Not Modus
.Calculation = IIf(Modus = True, xlManual, intCalculation)
.Cursor = IIf(Modus = True, 2, -4143)
End With
End Sub


Anzeige
AW: alle *.txt Files in einem Ordner öffnen und ...
12.05.2008 06:53:34
schauan
Hallo Peter,
wenn ein File offen sein muss, dann prüfe vor Ausführung mit Workbooks.Count.
Hoffe geholfen zu haben Grüße von André aus Gera - Excel-97-2003

Anzeige
;

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige