Elektroda.pl
Elektroda.pl
X
Elektroda.pl
Proszę, dodaj wyjątek dla www.elektroda.pl do Adblock.
Dzięki temu, że oglądasz reklamy, wspierasz portal i użytkowników.

Import danych *.txt do Excela

17 Cze 2008 23:47 7392 4
  • Poziom 10  
    Szukałem, szukałem i... jakoś nic nie znalazłem...
    Proszę więc o pomoc. Zarejestrowałem nowe makro, które ma importować pliki *.txt. Wszystko działa ok. pod warunkiem, że importuję pliki o tej samej nazwie i z tej samej lokalizacji. Muszę jednak codziennie zaimportować nowy plik z nową nazwą (w nazwie jest aktualna data, np. dokumenty_17.06.08.txt - radzę sobie z tym w ten sposób, że usuwam datę z nazwy ale nie jest to dla mnie praktyczne).
    I tu prośba o pomoc, jak zrobić, żebym mógł ręcznie wskazać plik txt do importu?

    moje makro:

    Code:

    Sub Import()
    '
    ' Import Makro
    '
       
       'zapobiega "migotaniu" ekranu podczas wykonywania makra:
       Application.ScreenUpdating = False
     
       
        With ActiveSheet.QueryTables.Add(Connection:= _
            "TEXT;C:\Temp\dokumenty.txt" _
            , Destination:=Range("A1"))
            .Name = "dokumenty"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 1250
            .TextFileStartRow = 5
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = True
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1, 1)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
       
    End Sub

  • Pomocny post
    Poziom 42  
    Code:

    Dim MyDay
    MyDay = Day(Date)

    i pozostałe części, następnie wrzucasz w stringa. Wada - zależne od dnia aktualnego - brak możliwości importu starszych.

    alternatywa:
    Code:

    dlgAnswer = Application.Dialogs(xlDialogOpen).Show

    W ten sposób będziesz mógł wybierać plik.
  • Poziom 10  
    a czy mógłbym prosić o wrzucenie tego do mojego kodu bo niestety nie za bardzo wiem co usunąć i gdzie dodać żeby było dobrze. Przepraszam ale jestem troszkę zielony...

    Dodano po 2 [godziny] 17 [minuty]:

    Problem został rozwiązany. Można zamknąć temat.
  • Poziom 31  
    lapbeer napisał:
    a czy mógłbym prosić o wrzucenie tego do mojego kodu bo niestety nie za bardzo wiem co usunąć i gdzie dodać żeby było dobrze. Przepraszam ale jestem troszkę zielony...

    Dodano po 2 [godziny] 17 [minuty]:

    Problem został rozwiązany. Można zamknąć temat.


    jeśli możesz to napisz jak rozwiązałeś problem , chętnie skorzystam z twojego doświadczenia
  • Poziom 10  
    Pomoc nadeszła z innego forum :-)
    http://forum.idg.pl/index.php?showtopic=149197

    Kod zmodyfikowany do moich potrzeb

    Code:
    Option Explicit
    

    Sub Import()
    '
    ' Importu Makro
    ' Makro zarejestrowane 2008-06-13,
    '

    '
    'zapobiega "migotaniu" ekranu podczas wykonywania makra:
       Application.ScreenUpdating = False
       
       
        Dim strFullName         As String
        strFullName = TxtSelect()
        If Len(strFullName) = 0 Then
            MsgBox "Nie wybrano pliku !"
            Exit Sub
        End If
        'tu należy określić nazwę arkusza -w tym przypadku "import"
        Call QryImportTxt(ThisWorkbook.Worksheets("import"), strFullName)
    End Sub

    Function TxtSelect() As String
        Dim vrtSelectedItem     As Variant
        With Application.FileDialog(msoFileDialogFilePicker)
            .AllowMultiSelect = False
            .Filters.Clear
            .Filters.Add "Pliki tekstowe", "*.txt"
            If .Show = -1 Then
                TxtSelect = .SelectedItems.Item(1)
            End If
        End With
    End Function

    Public Sub QryImportTxt(Wsh As Worksheet, _
                            ByVal sFullName As String)
        On Error GoTo QryImportTxt_Error

        With Wsh
            .Cells.ClearContents
            With .QueryTables.Add(Connection:="TEXT;" & sFullName, _
                                  Destination:=.Range("A1"))
            .Name = "dokumenty"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 1250
            .TextFileStartRow = 5
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = True
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1, 1)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
            End With
        End With
        MsgBox "Zaimportowano poprawnie"
       
    QryImportTxt_Exit:
        On Error Resume Next
        Call DeleteAllQueries(Wsh)
        Exit Sub

    QryImportTxt_Error:
        MsgBox "Błąd : ( " & Err.Number & " ) " & Err.Description & vbCrLf & _
               "Procedura  : " & "QryImportTxt", vbExclamation
        Resume QryImportTxt_Exit
    End Sub

    Public Sub DeleteAllQueries(Wsh As Worksheet)
        Dim i                   As Long
        Dim strQN               As String
        On Error Resume Next
        With Wsh
            For i = .QueryTables.Count To 1 Step -1
                strQN = .QueryTables(i).Name
                .QueryTables(i).Delete
                .Names(strQN).Delete
            Next
        End With
    End Sub