TXT Dateien einlesen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub importTextFiles() Dim vntItem As Variant, rng As Range Dim vntFiles() As String, vntValues() As Variant Dim lngI As Long, lngN As Long, lngRow As Long Dim strTemp As String Dim ff As Integer With Application.FileDialog(msoFileDialogFilePicker) .InitialFileName = "E:\Forum" 'Startverzeichnis .Title = "Dateien auswählen" .ButtonName = "Auswahl..." .InitialView = msoFileDialogViewList .AllowMultiSelect = True .Filters.Clear .Filters.Add "Text Dateien", "*.txt; *.csv", 1 .FilterIndex = 1 If .Show = -1 Then Redim vntFiles(.SelectedItems.Count - 1) For Each vntItem In .SelectedItems vntFiles(lngI) = vntItem lngI = lngI + 1 Next End If End With If lngI > 0 Then For lngI = 0 To UBound(vntFiles) lngRow = 0 ff = FreeFile Open vntFiles(lngI) For Input As #ff Do While Not EOF(ff) lngRow = lngRow + 1 Line Input #ff, strTemp Select Case lngRow Case 5, 15, 46, 84, 97 'Zeilen die importiert werden Redim Preserve vntValues(lngN) vntValues(lngN) = strTemp lngN = lngN + 1 Case Else End Select Loop Close #ff Next End If If lngN > 0 Then Set rng = ThisWorkbook.Sheets("Tabelle1").Range("A2").Resize(lngN, 1) 'Ausgabezelle rng = Application.Transpose(vntValues) rng.TextToColumns Destination:=rng.Cells(1, 1), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ Semicolon:=False, Comma:=False, Space:=False, Other:=False End If Set rng = Nothing End Sub

If lngI > 0 Then For lngI = 0 To UBound(vntFiles) Redim Preserve vntValues(lngN) vntValues(lngN) = vntFiles(lngI) lngN = lngN + 1 lngRow = 0 ff = FreeFile Open vntFiles(lngI) For Input As #ff Do While Not EOF(ff) lngRow = lngRow + 1 Line Input #ff, strTemp Select Case lngRow Case 5, 15, 46, 84, 97 'Zeilen die importiert werden Redim Preserve vntValues(lngN) vntValues(lngN) = strTemp lngN = lngN + 1 Case Else End Select Loop Close #ff Next End If

Hallo Manfred,
die Fehlenden "" hätten dir aber schon selber auffallen können!

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub importTextFiles()
Dim vntItem As Variant, rng As Range
Dim vntFiles() As String, vntValues() As Variant
Dim lngI As Long, lngN As Long, lngRow As Long
Dim strTemp As String
Dim ff As Integer

With Application.FileDialog(msoFileDialogFilePicker)
  .InitialFileName = "E:\Forum" 'Startverzeichnis
  .Title = "Dateien auswählen"
  .ButtonName = "Auswahl..."
  .InitialView = msoFileDialogViewList
  .AllowMultiSelect = True
  .Filters.Clear
  .Filters.Add "Text Dateien", "*.txt; *.csv", 1
  .FilterIndex = 1
  If .Show = -1 Then
    Redim vntFiles(.SelectedItems.Count - 1)
    For Each vntItem In .SelectedItems
      vntFiles(lngI) = vntItem
      lngI = lngI + 1
    Next
  End If
End With

If lngI > 0 Then
  For lngI = 0 To UBound(vntFiles)
    Redim Preserve vntValues(lngN)
    vntValues(lngN) = Mid(vntFiles(lngI), InStrRev(vntFiles(lngI), "\") + 1)
    lngN = lngN + 1
    lngRow = 0
    ff = FreeFile
    Open vntFiles(lngI) For Input As #ff
    Do While Not EOF(ff)
      lngRow = lngRow + 1
      Line Input #ff, strTemp
      Select Case lngRow
        Case 5, 15, 46, 84, 97  'Zeilen die importiert werden
          Redim Preserve vntValues(lngN)
          vntValues(lngN) = strTemp
          lngN = lngN + 1
        Case Else
      End Select
    Loop
    Close #ff
  Next
End If

If lngN > 0 Then
  Set rng = ThisWorkbook.Sheets("Tabelle1").Range("A2").Resize(lngN, 1) 'Ausgabezelle
  rng = Application.Transpose(vntValues)
  rng.TextToColumns Destination:=rng.Cells(1, 1), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False
End If

Set rng = Nothing
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

TXT Dateien einlesen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread