Text-Datei mit vielen Kopfzeilen drin importieren

Hallo Thorsten!
Da war noch ein Fehler beim Sprung über die Kopfdaten!
So tut's

Sub TextImportSpecial()
'Import einer Textdatei
'start bei Datensatz 24 bis 480
'sprung zu 528 bis 1004 usw....
Dim iRow As Long, iCol As Integer, lngC As Long
Dim sFile As String, sTxt As String, varTxt() As Variant
On Error GoTo ERRORH
sFile = Application.GetOpenFilename("Text Files (*.txt;*.csv;*.dat), *.txt;*.csv;*.dat")
   If Dir(sFile) = "" Then
   Beep
   MsgBox "Datei wurde nicht gefunden!"
   GoTo ERRORH
   End If
Application.ScreenUpdating = False
Application.StatusBar = "Lese Datei  -  Bitte Warten"
iRow = 1
iCol = 1
Close
Open sFile For Input As #1
   Do Until EOF(1)
   Line Input #1, sTxt
      Do While InStr(sTxt, ";")
      lngC = lngC + 1
      sTxt = Right(sTxt, Len(sTxt) - InStr(sTxt, ";"))
      Loop
   Loop
Close
ReDim varTxt(lngC - 1)
lngC = 0
Open sFile For Input As #1
   Do Until EOF(1)
   Line Input #1, sTxt
      Do While InStr(sTxt, ";")
      varTxt(lngC) = Left(sTxt, InStr(sTxt, ";") - 1)
      lngC = lngC + 1
      sTxt = Right(sTxt, Len(sTxt) - InStr(sTxt, ";"))
      Loop
   Loop
Close
lngC = 23
   Do
      lngC = lngC + 1

      If lngC Mod 504 = 0 Then
         lngC = lngC + 24
      End If


   Application.StatusBar = "Importiere Datensatz " & Format(lngC, "#,##0") & " von " & _
      Format(UBound(varTxt), "#,##0") & " ( " & Int(lngC / UBound(varTxt) * 100) & _
      " % ) -  Bitte Warten"
   Cells(iRow, iCol) = varTxt(lngC)
   iCol = iCol + 1
      If iCol > 5 Then
      iRow = iRow + 1
      iCol = 1
      End If
   Loop While lngC < UBound(varTxt)
ERRORH:
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub

Code eingefügt mit Syntaxhighlighter 2.5

Gruß Sepp

Ein kluger Mann macht nicht alle Fehler selbst.
Er lässt auch anderen eine Chance.
(Sir Winston Churchill)

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub t() ' hier ersteinmal den dateinamen festlegen Open dateiname For Input As #1 Do Until EOF(1) Line Input #1, sTxt arr = fncSplit(sTxt, ",") For iCol = 0 To UBound(arr) iRow = Fix(iCol / 256) * 600 + 1 + iPlus iColT = iCol Mod 256 + 1 'treshold? Cells(iRow, iColT).Value = arr(iCol) Next iCol iPlus = iPlus + 1 n = n + 1 Loop Close iRow = 0 iColT = 0 iCol = 0 arr = 0 n = 0 iPlus = 0 End Sub

Function fncSplit(SplitText As String, Delimiter As Variant) As Variant Dim iFile As Integer, iCounter As Integer Dim arr() As String Dim sTxt As Double Dim wer1 As Integer, wer2 As Integer Do While SplitText <> "" ReDim Preserve arr(iCounter) If InStr(SplitText, Delimiter) Then sTxt = Left(SplitText, _ InStr(SplitText, Delimiter) - 1) 'wer1 = CInt(sTxt) If sTxt < treshold Then sTxt = "0" End If arr(iCounter) = sTxt SplitText = Right(SplitText, Len(SplitText) - InStr(SplitText, Delimiter)) Else 'wer2 = CInt(SplitText) If SplitText < treshold Then SplitText = "0" End If arr(iCounter) = SplitText SplitText = "" End If iCounter = iCounter + 1 Loop fncSplit = arr End Function

Hallo Torsten!
Probier mal diesen Code.

Sub TextImport()
Dim iRow As Long, iCol As Integer, lngC As Long
Dim sFile As String, sTxt As String, varTxt() As Variant
On Error GoTo ERRORH
sFile = Application.GetOpenFilename("Text Files (*.txt;*.csv;*.dat), *.txt;*.csv;*.dat")
   If Dir(sFile) = "" Then
   Beep
   MsgBox "Datei wurde nicht gefunden!"
   GoTo ERRORH
   End If
Application.ScreenUpdating = False
Application.StatusBar = "Lese Datei  -  Bitte Warten"
iRow = 1
iCol = 1
Close
Open sFile For Input As #1
   Do Until EOF(1)
   Line Input #1, sTxt
      Do While InStr(sTxt, ";")
      lngC = lngC + 1
      sTxt = Right(sTxt, Len(sTxt) - InStr(sTxt, ";"))
      Loop
   Loop
Close
ReDim varTxt(lngC - 1)
lngC = 0
Open sFile For Input As #1
   Do Until EOF(1)
   Line Input #1, sTxt
      Do While InStr(sTxt, ";")
      varTxt(lngC) = Left(sTxt, InStr(sTxt, ";") - 1)
      lngC = lngC + 1
      sTxt = Right(sTxt, Len(sTxt) - InStr(sTxt, ";"))
      Loop
   Loop
Close
lngC = 23
   Do
   lngC = lngC + 1
   Application.StatusBar = "Importiere Datensatz " & Format(lngC, "#,##0") & " von " & _
      Format(UBound(varTxt), "#,##0") & " ( " & Int(lngC / UBound(varTxt) * 100) & _
      " % ) -  Bitte Warten"
   Cells(iRow, iCol) = varTxt(lngC)
   iCol = iCol + 1
      If iCol > 5 Then
      iRow = iRow + 1
      iCol = 1
      End If
      If lngC Mod 504 = 0 Then
      lngC = lngC + 23
      End If
   Loop While lngC < UBound(varTxt)
ERRORH:
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub

Code eingefügt mit Syntaxhighlighter 2.5

Gruß Sepp

Ein kluger Mann macht nicht alle Fehler selbst.
Er lässt auch anderen eine Chance.
(Sir Winston Churchill)

Beliebteste Forumthreads (12 Monate)

Text-Datei mit vielen Kopfzeilen drin importieren

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Text-Datei mit vielen Kopfzeilen drin importieren

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread