Bestimmte Daten aus einer .txt Datei in Excel impo

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Markus,
da sich das Programm die Datei selbst suchen muss, ist es ein wenig aufwendiger geworden. Schneller ginge es, wenn die Textdateien immer im selben Ordner auf der selben Festplatte wären.

Option Explicit
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Const MAX_PATH = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type
Private lngDirCount As Long
Private strFile As String
Private bolgefunden As Boolean
Public Sub Importieren()
    Dim lngZeile As Long, intFile As Integer, strText As String, varArray As Variant, intIndex As Integer
    Dim intSheetindex As Integer, lngAusgabezeile As Long, myFSO As Object, myDrives As Object, myDrive As Object
    Set myFSO = CreateObject("Scripting.FileSystemObject")
    Set myDrives = myFSO.Drives
    For Each myDrive In myDrives
        If myDrive.IsReady Then
            lngDirCount = 1
            bolgefunden = False
            FindFiles myDrive.DriveLetter & ":\", "L" & Format(Date, "yy") & Format(Date, "mm") & Format(Date, "dd") & ".txt"
            If bolgefunden Then Exit For
        End If
    Next
    If bolgefunden Then
        lngAusgabezeile = Worksheets("Tabelle A").Columns(1).Find(Date).Row
        Reset
        intFile = FreeFile
        Open strFile For Input As #intFile
        Do Until EOF(intFile)
            Input #intFile, strText
            lngZeile = lngZeile + 1
            If lngZeile - 6 > 0 And (lngZeile - 6) Mod 15 = 0 Then
                intSheetindex = intSheetindex + 1
                varArray = Split(strText, " ")
                For intIndex = 0 To UBound(varArray)
                    Worksheets("Tabelle " & Chr$(intSheetindex + 64)).Cells(lngAusgabezeile, intIndex + 2).Value = varArray(intIndex)
                Next
            End If
        Loop
        Close #intFile
    Else
        MsgBox "Die Datei L" & Format(Date, "yy") & Format(Date, "mm") & Format(Date, "dd") & ".txt wurde nicht gefunden.", 48, "Hinweis"
    End If
End Sub
Private Sub FindFiles(ByVal strFolderPath As String, ByVal strSearch As String)
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        GetFilesInFolder strFolderPath, strSearch
        Do
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
                strDirName = TrimNulls(WFD.cFileName)
                If (strDirName <> ".") And (strDirName <> "..") Then
                    lngDirCount = lngDirCount + 1
                    FindFiles strFolderPath & strDirName, strSearch
                End If
            End If
        Loop While FindNextFile(lngSearch, WFD)
        FindClose lngSearch
    End If
End Sub
Private Sub GetFilesInFolder(ByVal strFolderPath As String, ByVal strSearch As String)
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strFileName As String
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & strSearch, WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        Do
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then
                strFileName = TrimNulls(WFD.cFileName)
                strFile = strFolderPath & strFileName
                bolgefunden = True
                Exit Sub
            End If
        Loop While FindNextFile(lngSearch, WFD)
        FindClose lngSearch
    End If
End Sub
Private Function TrimNulls(ByVal strStringIn As String) As String
    If InStr(strStringIn, Chr(0)) > 0 Then strStringIn = Left$(strStringIn, InStr(strStringIn, Chr(0)) - 1)
    TrimNulls = strStringIn
End Function

Gruß
Nepumuk

Hallo Markus,
kleine Änderung in der Fehlerroutine:

Public Sub Importieren()
    Dim lngZeile As Long, intFile As Integer, strText As String, varArray As Variant, intIndex As Integer
    Dim intSheetindex As Integer, lngAusgabezeile As Long
    On Error Resume Next
    lngAusgabezeile = Worksheets("Tabelle A").Columns(1).Find(Date).Row
    On Error GoTo Fehlerausgang
    If lngAusgabezeile = 0 Then Err.Number = 513: GoTo Fehlerausgang
    Reset
    intFile = FreeFile
    Open "C:\Marketing\Lieferung\L" & Format(Date, "yy") & Format(Date, "mm") & Format(Date, "dd") & ".txt" For Input As #intFile
    Do Until EOF(intFile)
        Input #intFile, strText
        lngZeile = lngZeile + 1
        If lngZeile - 6 > 0 And (lngZeile - 6) Mod 15 = 0 Then
            intSheetindex = intSheetindex + 1
            varArray = Split(strText, " ")
            For intIndex = 0 To UBound(varArray)
                Worksheets("Tabelle " & Chr$(intSheetindex + 64)).Cells(lngAusgabezeile, intIndex + 2).Value = varArray(intIndex)
            Next
            varArray = Empty
        End If
        If intSheetindex = 26 Then Exit Do
    Loop
    Close #intFile
    Exit Sub
Fehlerausgang:
    Reset
    Select Case Err.Number
        Case 53: MsgBox "Die Datei L" & Format(Date, "yy") & Format(Date, "mm") & Format(Date, "dd") & ".txt wurde nicht gefunden.", 16, "Fehlermeldung"
        Case 76: MsgBox "Der Pfad zur Datei wurde nicht gefunden.", 16, "Fehlermeldung"
        Case 513: MsgBox "Das Datum " & CStr(Date) & " ist nicht in der Tabelle.", 16, "Fehlermeldung"
        Case Else: MsgBox "Fehler " & CStr(Err.Number) & vbLf & Err.Description, 16, "Fehlermeldung"
    End Select
End Sub

Ich hoffe, das wars.
Gruß
Neüpumuk

Beliebteste Forumthreads (12 Monate)

Bestimmte Daten aus einer .txt Datei in Excel impo

41
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bestimmte Daten aus einer .txt Datei in Excel impo

41 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

41
Beiträge zum Forumthread

Beiträge zu diesem Forumthread