Skocz do zawartości


Close Open
Close Open
Zdjęcie
- - - - -

[Excel VBA] Zapis z Excela do pliku .txt


  • Please log in to reply
8 replies to this topic

#1 Rito

Rito

    Adept

  • Forumowicze
  • Pip
  • 3 Postów:

Napisany 01 marzec 2018 - 14:35

Witam,

mam taki otóż problem, z którym własnymi siłami nie mogę sobie poradzić. Może ktoś mógłby mi pomóc. 

Chodzi o makro które z arkusza 2 zaznaczy komórki A2:A300 i zapisze je do pliku txt o nazwie komórki np. A9. Ewentualnie jeśli nie sprawia to dużo problemu to od A2: do pierwszej pustej komórki 

 

Pozdrawiam i z góry dziękuje :)



#2 broda99

broda99

    Rozmowny

  • Forumowicze
  • PipPipPipPipPipPip
  • 574 Postów:
  • Płeć:Mężczyzna
  • Lokalizacja:W-wa

Napisany 07 marzec 2018 - 10:10

VBA > w Arkusz2 wklej:

 

Option Explicit

Sub toTXT()
Dim txtFile As String, d As Integer, w As Integer

'On Error Resume Next

Sheets(2).Select

Application.ScreenUpdating = False
Application.DisplayAlerts = False

txtFile = "C:\" & Range("A9").Value & ".txt"

d = Cells(Rows.Count, "A").End(xlUp).Row
w = Cells(1, Columns.Count).End(xlToLeft).Column

Range(Cells(1, 2), Cells(d, w)).Clear

ThisWorkbook.ActiveSheet.SaveAs txtFile, xlTextWindows
ThisWorkbook.Close False

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
 

 



#3 Rito

Rito

    Adept

  • Forumowicze
  • Pip
  • 3 Postów:

Napisany 16 marzec 2018 - 00:06

Niestety nie działa :) podczas próby wykonania makra wyłącza mi skoroszyt



#4 Rito

Rito

    Adept

  • Forumowicze
  • Pip
  • 3 Postów:

Napisany 19 marzec 2018 - 08:34

ok napisałem takie coś niby działa ale jest jeden problem zapisuje mi cały dokument pod nazwą z komórki A9 a nie tylko nowy plik ktoś wie jak to rozwiązać ?

 

  ActiveCell.Range("A1:ALL1").Select
    Selection.Copy
    Sheets("Transponowanie ").Select
    ActiveCell.Offset(0, 0).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveCell.Range("A1:ALL1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Retranspozycja").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
         Sheets("Retranspozycja").Select
  ThisWorkbook.ActiveSheet.SaveAs FileName:= _
        "C:\Users\ppietrucha\Desktop\LDT automat test\" & Range("A9").Value & ".ldt" _
        , FileFormat:=xlTextMSDOS, CreateBackup:=True
 
End Sub


#5 vbCritical

vbCritical

    Fan Visual Basic

  • Forumowicze
  • PipPipPipPipPip
  • 287 Postów:
  • Płeć:Mężczyzna

Napisany 14 kwiecień 2018 - 23:42

Witam,

 

jeśli chodzi o zapis linii z tekstem używam takiego kodu:

 

Sub Test()

    Dim fso As New FileSystemObject

    Dim objfile As Object

    Dim znak As String = Chr(10)

 

    Set objfile = fso.CreateTextFile({pełna_ścieżka_do_pliku}, True)

   

    With wynik

        objfile.Write "4.0" & znak(0)

        objfile.Write "Zapis danych" & znak(0)

    End With

   

    objfile.Close

End Sub

 

Należy pamiętać, że jest to obiekt File System Object, który należy uruchomić w Referencjach wybierając: Microsoft Scripting Runtime. To jest lepsze rozwiązanie z uwagi na możliwość modyfikowania znaku końca linii:

CRLF -> połączenie 2 znaków CHR(13) + CHR(10) (stosowane w windows)

lub

LF -> zastosowanie 1 znaku CHR(10) (stosowane w unix)



#6 jalamas

jalamas

    Bywalec

  • Forumowicze
  • PipPipPipPipPip
  • 322 Postów:

Napisany 15 kwiecień 2018 - 19:08

vbCritical napisał:

Należy pamiętać, że jest to obiekt File System Object, który należy uruchomić w Referencjach
Niekoniecznie wystarczy skorzystać z późnego wiązania…

Ale wracając do pytania 2 przykłady:

Sub testZapiszArkusz2Txt()
    With ThisWorkbook
        If ZapiszArkusz2Txt(objWs:=.Worksheets("Retranspozycja"), _
                            sPathTxtFile:=.Path, _
                            sTxtName:="PobierzSkadChcesz") Then MsgBox "OK"
    End With
End Sub
Function ZapiszArkusz2Txt(objWs As Excel.Worksheet, _
                          ByVal sPathTxtFile As String, _
                          ByVal sTxtName As String) As Boolean
    On Error GoTo ZapiszArkusz2Txt_Error
    Dim WBookTmp                  As Excel.Workbook
    If Right(sPathTxtFile, 1) <> "\" Then sPathTxtFile = sPathTxtFile & "\"
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False         ' tu sie zastanow
        .Cursor = xlWait
    End With
    ' xlWBATWorksheettylko z jednym arkuszem !!!!
    Set WBookTmp = Application.Workbooks.Add(xlWBATWorksheet)
    With WBookTmp
        objWs.Copy After:=.Sheets(1)
        .Sheets(1).Delete
        .SaveAs Filename:=sPathTxtFile & sTxtName & ".ldt" _
                          , FileFormat:=xlTextMSDOS, CreateBackup:=True
        .Close SaveChanges:=False
    End With
    ZapiszArkusz2Txt = True
    '---------------------
ZapiszArkusz2Txt_Exit:
    On Error Resume Next
    If Not (WBookTmp Is Nothing) Then
        WBookTmp.Close SaveChanges:=False
        Set WBookTmp = Nothing
    End If
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .Cursor = xlDefault
    End With
    Exit Function
ZapiszArkusz2Txt_Error:
    MsgBox "Błąd Nr: " & Err.Number & vbNewLine & _
           "Opis błędu:" & Err.Description & vbNewLine & _
           "Procedura ZapiszArkusz2Txt "
    Resume ZapiszArkusz2Txt_Exit
End Function
'-------------------------------
Sub testZapiszZakres2Txtt()
    With ThisWorkbook
        ' zamiast UsedRange wybierz Range jaki chcesz
        If ZapiszZakres2Txt(objRn2Copy:=.Worksheets("Retranspozycja").UsedRange, _
                            sPathTxtFile:=.Path, _
                            sTxtName:="PobierzSkadChcesz") Then MsgBox "OK"
    End With
End Sub
Function ZapiszZakres2Txt(objRn2Copy As Excel.Range, _
                          ByVal sPathTxtFile As String, _
                          ByVal sTxtName As String) As Boolean
    On Error GoTo ZapiszZakres2Txt_Error
    If Right(sPathTxtFile, 1) <> "\" Then sPathTxtFile = sPathTxtFile & "\"
    Dim WBookTmp                  As Excel.Workbook
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False         ' tu sie zastanow
        .Cursor = xlWait
    End With
    ' xlWBATWorksheettylko z jednym arkuszem !!!!
    Set WBookTmp = Application.Workbooks.Add(xlWBATWorksheet)
    With WBookTmp
        With .Sheets(1)
            objRn2Copy.Copy
            DoEvents
            'ponizsze niekoniecznie
            .Cells.PasteSpecial Paste:=xlPasteValues, _
                                Operation:=xlNone, _
                                SkipBlanks:=False, _
                                Transpose:=False
            Application.CutCopyMode = False
        End With
        .SaveAs Filename:=sPathTxtFile & sTxtName & ".ldt" _
                          , FileFormat:=xlTextMSDOS, CreateBackup:=True
        .Close False
    End With
    ZapiszZakres2Txt = True
    '---------------------
ZapiszZakres2Txt_Exit:
    On Error Resume Next
    If Not (WBookTmp Is Nothing) Then
        WBookTmp.Close SaveChanges:=False
        Set WBookTmp = Nothing
    End If
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .Cursor = xlDefault
    End With
    Exit Function
ZapiszZakres2Txt_Error:
    MsgBox "Błąd Nr: " & Err.Number & vbNewLine & _
           "Opis błędu:" & Err.Description & vbNewLine & _
           "Procedura ZapiszZakres2Txt "
    Resume ZapiszZakres2Txt_Exit
End Function


#7 vbCritical

vbCritical

    Fan Visual Basic

  • Forumowicze
  • PipPipPipPipPip
  • 287 Postów:
  • Płeć:Mężczyzna

Napisany 15 kwiecień 2018 - 21:55

Witam,

 

Niekoniecznie wystarczy skorzystać z późnego wiązania…

 

Tak w ramach nauki. Czy możesz przedstawić to wiązanie?



#8 jalamas

jalamas

    Bywalec

  • Forumowicze
  • PipPipPipPipPip
  • 322 Postów:

Napisany 17 kwiecień 2018 - 08:50

Dim oFSO                      As Object    ' File System Object
Set oFSO = CreateObject("Scripting.FileSystemObject")


#9 vbCritical

vbCritical

    Fan Visual Basic

  • Forumowicze
  • PipPipPipPipPip
  • 287 Postów:
  • Płeć:Mężczyzna

Napisany 17 kwiecień 2018 - 21:24

Witam,

 

Dim oFSO                      As Object    ' File System Object
Set oFSO = CreateObject("Scripting.FileSystemObject")

 

dziękuje. Działa prawidłowo. Metoda, którą przedstawiłeś... zupełnie o niej zapomniałem. Jeszcze raz dziękuje.






0 Użytkowników czyta ten temat

0 użytkowników, 0 gości, 0 anonimowych użytkowników