Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1412to1416
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Mehrere Textdateien in Arbeitsmappe importiere

Mehrere Textdateien in Arbeitsmappe importiere
07.03.2015 22:21:02
Minion
Hallo,
ich brauche Hilfe beim Erstellen eines Maktros zur automatischen Datenauswertung!
ich möchte gerne aus einem definierten Ordner alle vorhandenen Textdateien in Excel importieren, allerdings sollen die einzelnen Datenreihen wenn möglich in verschiedene Tabellenblätter importiert werden oder nebeneinander. Bisher habe ich es mit folgendem Code nur geschafft sie untereinander zu importieren:

Sub import()
Dim strPfad As String
Dim FSO As Object
Dim file
Dim lngLR As Long
strPfad = "G:\...\"
Set FSO = CreateObject("scripting.filesystemobject")
For Each file In FSO.getfolder(strPfad).Files
strDestination = "A" & Cells(Rows.Count, 1).End(xlUp).Row + 1
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & strPfad & strFileName, Destination:=Range( _
strDestination))
.Name = "Datenauswertung"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next
End Sub

Kann mir jemand helfen? Was muss ich ändern?
LG

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Mehrere Textdateien in Arbeitsmappe importiere
08.03.2015 17:42:19
fcs
Hallo Minion,
hier 2 angepasste Makros
import_Tabellen
Die Textdateien werden beginned mit dem aktiven Blatt in unterschiedlichen Tabellenblättern importiert.
Die etwas umfangreiche Fehlerbehandlung ist erforderlich für den Fall dass Textdateien gleichen Namens importiert werden sollen z.B wenn der Import versehentlich ein 2. Mal gestartet wird.
import_Nebeneinander
Die Inhalte der Textdateien werden nebeneinander importiert. Durch Änderung der 0 bei der Berechnung der nächsten Einfüge-Spalte in 1 wird zwischen den Daten der Textdateien jeweils eine Spalte leer gelassen.
Gruß
Franz
Sub import_Tabellen()
Dim strPfad As String
Dim FSO As Object
Dim file
On Error GoTo Fehler
strPfad = "G:\...\"
'    strPfad = "C:\Users\Public\Test\ABC\"
Application.ScreenUpdating = False
Set FSO = CreateObject("scripting.filesystemobject")
For Each file In FSO.getfolder(strPfad).Files
ActiveSheet.Name = Left(file.Name, InStrRev(file.Name, ".") - 1)
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & strPfad & file.Name, Destination:=Range("A1"))
.Name = "Datenauswertung"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next_File:
ActiveWorkbook.Worksheets.Add After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
Next
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case 1004
Select Case MsgBox("Fehler-Nr.: " & .Number & vbLf & .Description & vbLf & vbLf  _
_
& "Text-Datei ohne Umbenennung des Blattes laden?" & vbLf _
& "Bei ""Abbrechen"" wird das Makro beendet", _
vbQuestion + vbYesNoCancel, "Makro: Import")
Case vbCancel
Case vbNo
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Resume Next_File
Case vbYes
Resume Next
End Select
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Application.ScreenUpdating = True
End Sub
Sub import_Nebeneinander()
Dim strPfad As String
Dim FSO As Object
Dim file
Dim Spalte As Long
On Error GoTo Fehler
strPfad = "G:\...\"
'    strPfad = "C:\Users\Public\Test\ABC\"
Application.ScreenUpdating = False
Set FSO = CreateObject("scripting.filesystemobject")
Spalte = 1 '1. Spalte in der eingefügt werden soll
For Each file In FSO.getfolder(strPfad).Files
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & strPfad & file.Name, Destination:=Cells(1, Spalte))
.Name = "Datenauswertung"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
'nächste Einfügespalte berechnen
With ActiveSheet.UsedRange
Spalte = .Column + .Columns.Count + 0 '0 = keine Leerspalte zwischen den Daten der  _
Textdateien
End With
Next
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Application.ScreenUpdating = True
End Sub

Anzeige
AW: Mehrere Textdateien in Arbeitsmappe importiere
10.03.2015 08:31:05
Minion
Hi fcs,
danke für die schnelle Antwort!
Leider funktioniert das ganze noch nicht, bei folgender Zeile wird mir ein Fehler angezeigt:
ActiveSheet.Name = Left(file.Name, InStrRev(file.Name, ".") - 1)
Muss ich da etwas ändern?
LG
Minion

AW: Mehrere Textdateien in Arbeitsmappe importiere
10.03.2015 11:20:24
fcs
Hallo Minion.
entweder hast du in den Dateinamen Sonderzeichen, die für Blattnamen nicht zulässig sind oder die Dateinamen sind länger als 31 Zeichen.
Ich mal eine Korrektur eingebaut, die den Dateinamen auf Eignung als Blattname prüft und ggf. eine manuelle Korrektur abfragt.
Gruß
Franz
Sub import_Tabellen()
Dim strPfad As String
Dim FSO As Object
Dim file
Dim strBlattname As String
On Error GoTo Fehler
strPfad = "G:\...\"
'    strPfad = "C:\Users\Public\Test\ABC\"
strPfad = "D:\Test\ABC\"
Application.ScreenUpdating = False
Set FSO = CreateObject("scripting.filesystemobject")
For Each file In FSO.getfolder(strPfad).Files
strBlattname = fncSheetName(Left(file.Name, InStrRev(file.Name, ".") - 1))
If strBlattname  "" Then
ActiveSheet.Name = strBlattname
End If
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & strPfad & file.Name, Destination:=Range("A1"))
.Name = "Datenauswertung"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next_File:
ActiveWorkbook.Worksheets.Add After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
Next
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Application.ScreenUpdating = True
End Sub
Function fncSheetName(ByVal strText As String, Optional ByVal strReplace As String = "_", _
Optional wkb As Workbook) As String
Dim intZeichen
Dim arrZeichen
Dim strName As String
Dim wks As Object
On Error GoTo Fehler
arrZeichen = Array(":", "\", "/", "?", "*", "[", "]")
If wkb Is Nothing Then Set wkb = ActiveWorkbook
strName = strText
Name_pruefen:
'unzulässige Zeichen im Blattnamen
For intZeichen = LBound(arrZeichen) To UBound(arrZeichen)
strName = VBA.Replace(strName, arrZeichen(intZeichen), strReplace)
Next
'Name einkürzen auf 31 zeichen
If Len(strName) > 31 Then
strName = Left(strName, 31)
End If
fncSheetName = strName
Set wks = wkb.Sheets(strName)
If Not wks Is Nothing Then
strName = InputBox("Der Blattname """ & strName & """ existiert bereits" & vbLf _
& "Bitte Name anpassen (max. Länge 31 zeichen", _
"Name für Blatt = Dateiname", strName)
If strName = "" Then
'der automatish generierte Blattname wird nicht verändert
fncSheetName = ""
Else
GoTo Name_pruefen
End If
End If
Err.Clear
Fehler:
With Err
Select Case .Number
Case 0
Case 9 'Blattname ist noch nicht vorhanden
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
fncSheetName = ""
End Select
End With
End Function

Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige