AW: Importieren von vielen txt-Dateien
vielen
Hallo
probier mal dieses Makro aus.
Alles gehört in ein Modul. Den Zielpfad bitte anpassen mit Backslash am Ende !!
Option Explicit
Const impPath As String = "D:\Test\"
Const impResultName As String = "Import_Result.xls"
Sub Import_Results_from_Textfiles()
'(C) Ramses
'Importiert die im Zielverzeichnis vorhandenen TXT-Dateien
'Die zu importierenden Dateien sind im Array aufgelistet
'und werden in eine Zielmappe importiert
Dim i As Integer, n As Integer
Dim Qe As Integer, writeCol As Integer
Dim txtLines As Long
Dim OldStatusbar
Dim impFiles() As Variant, DatImpArr As Variant, Text1 As String
Dim resWkb As Workbook, wkbChk As Boolean
Dim tarwks As Worksheet
impFiles = Array("1.txt", "2.txt", "3.txt", "4.txt", "5.txt", "10.txt", "20.txt")
wkbChk = False
'Prüfung ob Ergebnsidatei bereits geöffnet ist
For i = 1 To Workbooks.Count
If Workbooks(i).Name = impResultName Then
wkbChk = True
Exit For
End If
Next i
OldStatusbar = Application.DisplayStatusBar
'Wenn noch nicht geöffnet, prüfen ob diese Datei bereits vorhanden ist
If wkbChk = False Then
If Dir(impPath & impResultName) <> "" Then
'Wenn JA, Nachfrage ob diese Datei geöffnet werden soll
Qe = MsgBox("Die Ergebnisdatei """ & impResultName & """ existiert schon." & Chr$(13) & _
"Soll diese Datei geöffnet werden ?", vbQuestion + vbYesNo, "Neue Ergebnisdatei erstellen ?")
If Qe = vbYes Then
'Bei JA existierende Datei öffnen
Set resWkb = Workbooks.Open(impPath & impResultName)
Else
'Bei NEIN wird eine neue Datei angelegt
'mit einem spezifischen Zeitstempel
Set resWkb = Workbooks.Add
resWkb.SaveAs impPath & _
Left(impResultName, InStr(1, impResultName, ".") - 1) & _
Format(Time, "hh-mm-ss") & ".xls"
End If
End If
'Wenn noch keine Datei existiert
'wird eine neue angelegt
If Dir(impPath & impResultName) = "" Then
Set resWkb = Workbooks.Add
'Erstellen von entsprechender Anzahl Sheets
With resWkb
'+1 wegen Arrayzählung die bei 0 beginnt
For i = .Worksheets.Count To UBound(impFiles)
.Worksheets.Add after:=Sheets(Worksheets.Count)
Next i
'Umbenennen der Files entsprechend der
'zu importierender Namen
For i = 0 To UBound(impFiles)
Worksheets(i + 1).Name = impFiles(i)
Next i
'Speichern der Datei
resWkb.SaveAs impPath & impResultName
End With
Set resWkb = Workbooks(ActiveWorkbook.Name)
End If
End If
'FileImport starten
For i = 0 To UBound(impFiles)
Application.StatusBar = "File: " & impFiles(i) & " wird eingelesen"
Set tarwks = Worksheets("" & impFiles(i) & "")
'Einlesen der Daten
Close #1
'Den Namen und Pfad bitte anpassen
Open impPath & impFiles(i) For Input As #1
'Die anzahl ist nötig um die Grösse des Arrays zu deklarieren
'Zähler auf 0 setzen
txtLines = 0
Do While Not EOF(1) ' Schleife bis Dateiende.
Input #1, Text1 ' Hilfsvariable zum einlesen verwenden
'Zähler hochzählen
txtLines = txtLines + 1
Loop
Close #1
'Array redimensionieren
ReDim textArr(txtLines)
'Erneutes Öffnen um zum Dateianfang zu kommen
Open impPath & impFiles(i) For Input As #1
'Einlesen der zu importierenden Daten
'in das Array
For n = 1 To txtLines
Input #1, textArr(n)
Next n
'Schliessen der Datei
Close #1
With tarwks
'Spalte bestimmen wohin die Daten kommen
writeCol = .Cells(2, 255).End(xlToLeft).Column
'für den ersten Import belassen
If .Cells(2, writeCol) <> "" Then
writeCol = writeCol + 1
End If
'Daten schreiben
.Cells(1, writeCol) = "Import: " & Time
For n = 0 To txtLines
'Benutzerhinweis
Application.StatusBar = "File: " & impFiles(i) & " wird eingelesen." & _
"Datensatz " & n & " von " & txtLines
.Cells(n + 2, writeCol) = textArr(n)
Next n
End With
Next i
ActiveWorkbook.Save
Application.StatusBar = OldStatusbar
MsgBox ("Datenimport abgeschlossen")
End Sub
Gruss Rainer