Mehrere Textdateien in Arbeitsmappe importiere

Forumthread: 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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

Beliebteste Forumthreads (12 Monate)

Mehrere Textdateien in Arbeitsmappe importiere

Forumthread: Mehrere Textdateien in Arbeitsmappe importiere

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Mehrere Textdateien in Arbeitsmappe importiere

Forumthread: Mehrere Textdateien in Arbeitsmappe importiere

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread