Thema Datum  Von Nutzer Rating
Antwort
Rot Textdateien in Excel laden
17.01.2019 18:06:42 HUGO
NotSolved
17.01.2019 22:58:15 Flotter Feger
NotSolved
18.01.2019 09:09:04 HUGO
NotSolved
18.01.2019 12:25:11 Flotter Feger
NotSolved

Ansicht des Beitrags:
Von:
HUGO
Datum:
17.01.2019 18:06:42
Views:
882
Rating: Antwort:
  Ja
Thema:
Textdateien in Excel laden
Ich habe einen code erhalten
Dieser Sub ermöglicht es Textdateien in Excel als ein Worksheet einzulesen.
Der code gibt dem Worksheet den Namen der eingelesenen Textdatei.
Durch die Schleife ist es möglich mehrere Dateien auszuwählen und zu laden.
Problem bei dem Code ist, das wenn eine bereits geladene Datein erneut geladen wird,
ergibt das einen Laufzeitfehler 1004, da dann 2 sheets den selben Namen hätten.

Meine Aufgabe ist es eine funktion hinzuzufügen:
Es soll beim laden ermittelt werden welche dateien schon geöffnet sind,
falls die Datein schon geladen ist soll der Ladevorgang abgebrochen werden.

So sieht der Code derzeit aus:


'loads multiple data files in excel

Sub LoadData()

    With Application.FileDialog(msoFileDialogFilePicker)
            .Show
            AnzahlDatein = .SelectedItems.Count
            'cancel, after selection is zero
            If .SelectedItems.Count = 0 Then
                MsgBox "cancel"
                Exit Sub
            End If
            fStr = .SelectedItems(1)
        End With
        
    'open all files
        counter = 1
        Do While counter <> AnzahlDatein + 1
            fStr = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(counter)
            
    'find out the name of the file
            i = 1
            Dateiname = Right(fStr, i)
            Zeichen = Left(Dateiname, 1)
         
             Do While Zeichen <> "\"
                Zeichen = Left(Right(fStr, i), 1)
                i = i + 1
            Loop
            
     
    'open file
            Dateiname = Right(fStr, i - 2)
            Sheets("Speicher").Select
            
            With ThisWorkbook.Sheets("Speicher").QueryTables.Add(Connection:= _
            "TEXT;" & fStr, Destination:=Range("$A$1"))
                .Name = "CAPTURE"
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = True
                .RefreshOnFileOpen = False
                .RefreshStyle = xlInsertDeleteCells
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .TextFilePromptOnRefresh = False
                .TextFilePlatform = 437
                .TextFileStartRow = 1
                .TextFileParseType = xlDelimited
                .TextFileTextQualifier = xlTextQualifierDoubleQuote
                .TextFileConsecutiveDelimiter = False
                .TextFileTabDelimiter = True
                .TextFileSemicolonDelimiter = True
                .TextFileCommaDelimiter = False
                .TextFileSpaceDelimiter = False
                .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
                .TextFileTrailingMinusNumbers = True
                .Refresh BackgroundQuery:=False
            End With
    
    
    'copy data and place in new sheet
            Cells.Select
            Selection.Cut
            Sheets.Add
            Cells.Select
            ActiveSheet.Paste
            Cells(1, 4) = Dateiname
            

    'Change name [] to ()
        Range("B1").Select
        Cells.Find(What:="[", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        ActiveCell.Replace What:="[", Replacement:="(", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        Cells.FindNext(After:=ActiveCell).Activate
        Range("B1").Select
        Cells.Find(What:="]", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        ActiveCell.Replace What:="]", Replacement:=")", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        Cells.FindNext(After:=ActiveCell).Activate
            
    
    'use name as Sheetname
        For X = 1 To Sheets.Count
        If Worksheets(X).Range("D1").Value <> "" Then
        Sheets(X).Name = Worksheets(X).Range("D1").Value
        End If
        Next
 
    
    'increment counter for opening all files
        counter = counter + 1
        Loop
    
    Sheets("Berechnung").Select

End Sub

Könnt ihr mir helfen?


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Textdateien in Excel laden
17.01.2019 18:06:42 HUGO
NotSolved
17.01.2019 22:58:15 Flotter Feger
NotSolved
18.01.2019 09:09:04 HUGO
NotSolved
18.01.2019 12:25:11 Flotter Feger
NotSolved