Einige Stellen aus TXT-File auslesen

Hallo alle zusammen,
ich möchte einige Stellen aus einer TXT- Datei in ein Excelfile schreiben.
Dazu soll aus dem angehängten TXT-File (Das Orginal TXT-File hat ca.50000 Zeilen):
https://www.herber.de/bbs/user/66138.txt
das was sich hinter dem Suchkriterium:
Purchase Order, Item, Supplier, Unit Cost, Start Effective und End Effective befindet ausgelesen werden.
Nachfolgend der Output in Excel ohne die Zeile 7 (Zeile 7 zeigt die Stellen an die ausgelesen werden sollen)
Tabelle1

	A	B	C	D	E	F
2	Purchase Order	Item	Supplier	Unit Cost	Start Effective	End Effective
3	11aaaaaa	111 111 111 e	111111	11,9136	30.04.2005	28.02.2006
4	22aaaaaa	222 222 222 e	222222	22,9136	27.05.2005	28.03.2006
5	33aaaaaa	333 333 333 e	333333	33,9136	28.06.2005
6
7	zwischen 18 bis 28	zwischen 18 bis 36	zwischen 18 bis 24	zwischen 17 bis 47	zwischen 62 bis 70	zwischen 62 bis 70

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4
Die Suchkriterien tauchen in regelmäßigen Zeilenabstand erneut auf.
Der Zeilenabstand zwischen dem ersten Kriterium (Purchase Order) und dem letzten (End Effective) pro Item ist immer gleich.
Es kann auch passieren, dass nach dem Suchkriterium nicht steht wie es im Bsp.nach End Effective der Fall ist (Position 62 der Zeile 116) dann soll die Zelle leer bleiben.
Ich hoffe, mir kann jemand behilflich sein.
Vielen Dank im Voraus!
MFG Andre

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo André,
das ist kein Problem.

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

Option Explicit

Sub importText()
  Dim strFile As String, varText As Variant, varInput As Variant
  Dim lngRow As Long, lngIndex As Long, intFF As Integer
  Dim strTmp As String, intPos As Integer

  strFile = Application.GetOpenFilename("Textdateien (*.txt),*.txt")

  If strFile = CStr(False) Then Exit Sub

  varText = Range("A1:F1")
  Range("A2:F" & Rows.Count) = ""
  Range("A2:F" & Rows.Count).NumberFormat = "General"
  varInput = Range("A2:F" & Rows.Count)

  intFF = FreeFile

  Open strFile For Input As #intFF
  Do While Not EOF(intFF)
    Line Input #intFF, strTmp
    For lngIndex = 1 To UBound(varText, 2)
      intPos = InStr(Application.Max(1, intPos), strTmp, varText(1, lngIndex))
      If intPos > 0 Then
        If lngIndex = 1 Then lngRow = lngRow + 1
        If varInput(lngRow, lngIndex) = "" Then
          varInput(lngRow, lngIndex) = Trim(Mid(strTmp, intPos + Len(varText(1, lngIndex)) + 1, IIf(lngIndex < 4, 30, 14)))
          If IsNumeric(varInput(lngRow, lngIndex)) Then
            varInput(lngRow, lngIndex) = varInput(lngRow, lngIndex) * 1
          ElseIf IsDate(varInput(lngRow, lngIndex)) Then
            varInput(lngRow, lngIndex) = CDate(varInput(lngRow, lngIndex))
          Else
            varInput(lngRow, lngIndex) = ReplaceMulti(varInput(lngRow, lngIndex), " ", " ")
          End If
        End If
      End If
    Next
  Loop
  Close #intFF

  Range("A2:F" & Rows.Count) = varInput
  Range("A1:F1").EntireColumn.AutoFit
End Sub

Private Function ReplaceMulti(ByVal Expression As String, ByVal Find As String, ByVal Repl As String) As String
  ReplaceMulti = Expression
  Do While InStr(1, ReplaceMulti, Find) > 0
    ReplaceMulti = Replace(ReplaceMulti, Find, Repl)
  Loop
End Function

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Einige Stellen aus TXT-File auslesen

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Einige Stellen aus TXT-File auslesen

6 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)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread