Skocz do zawartości


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

[Excel VBA] Zapis z Excela do pliku .txt

Excel VBA

  • Please log in to reply
3 replies to this topic

#1 Marat

Marat

    Adept

  • Forumowicze
  • Pip
  • 2 Postów:

Napisany 13 lipiec 2017 - 22:33

Witam wszystkich forumowiczów.

 

Proszę o wyrozumiałość, ale dopiero od kilku dni zagłębiam się w temat VBA i jak na razie nie potrafię sobie poradzić.

Mam problem z napisaniem makra w Excelu, które wykona następujące operacje:

 

W arkuszu dane zawarte są w dwóch kolumnach (przykładowo A i B)
makro powinno działać w następujący sposób:

- zapisać dane z komórki B1 do pliku .txt z kodowaniem UTF-8, przykładowo do folderu Test zlokalizowanego na pulpicie
przy czym
nazwa pliku .txt musi być wzięta z komórki A1
następnie
zapisać dane z komórki B2 do pliku .txt jak wyżej z nazwą pliku z komórki A2

i tak dalej
ma działać tak długo, aż napotka pustą komórkę w kolumnie B

wtedy ma zakończyć działanie

 

będę naprawdę wdzięczny za pomoc, próbowałem coś sklecić samemu, ale, tak jak napisałem, przerasta to na razie moje możliwości.

 

Odnośnie zapisu do pliku .txt z kodowaniem UTF-8 znalazłem w necie coś takiego:

 

cytat:

Temat: VBA - Generowanie pliku txt z kodowaniem UTF-8
Witajcie,
czy ktoś z was potrafi za pomocą makra utworzyć plik txt który będzie miał włączone kodowanie UTF-8?
Poniższy kod tworzy plik z kodowaniem ANSI.
Wiecie jak to zmienić na UTF-8?

Dim fs, PaczkaPozwow
Set fs = CreateObject("Scripting.FileSystemObject")
Set PaczkaPozwow = fs.CreateTextFile("C:\test.txt", True)

Będę wdzięczny za pomoc.
18.02.2014, 18:55
Łukasz N.


Wystarczy podać trzeci parametr dla metody CreateTextFile

  fs.CreateTextFile("C:\test.txt", True,True)

18.02.2014, 19:35
Michał R.


Dzięki za odpowiedź.
Niestety dodanie tego parametru powoduje że plik jest w formacie unicode a nie UTF-8.
Ale jednak znalazłem rozwiązanie. Sprawę załatwia poniższy kod:


Option Explicit

Sub Save2File (sText, sFile)
Dim oStream
Set oStream = CreateObject("ADODB.Stream")
With oStream
.Open
.CharSet = "utf-8"
.WriteText sText
.SaveToFile sFile, 2
End With
Set oStream = Nothing
End Sub

' Example usage: '
Save2File "The data I want in utf-8", "c:\test.txt"

Dzięki za pomoc!
Łukasz N.

 

koniec cytatu

 

mnie niestety niewiele to dało, ale może będzie przydatne dla osoby bardziej zaawansowanej w temacie.
 



#2 broda99

broda99

    Rozmowny

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

Napisany 15 lipiec 2017 - 03:08

Option Explicit

Sub zapisz()
Dim i As Integer, d As Integer, l As Integer, nic As Variant
Dim w As String, n As String, czy As String, czy1 As String

On Error GoTo laend
    
If dirExists(Environ("USERPROFILE") & "\desktop\" & "test") = False Then
    czy = MsgBox("Katalog docelowy nie istnieje. Założyć?", vbYesNo, "Brak katalogu")
    If czy = vbYes Then
        MkDir (Environ("USERPROFILE") & "\desktop\" & "test")
    Else
        Exit Sub
    End If
End If

l = 0
d = Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To d
    w = Cells(i, 2).Value
    n = Environ("USERPROFILE") & "\desktop\" & "test\" & Cells(i, 1).Value & ".txt"
    
    If Dir(n) <> "" Then
        czy1 = MsgBox("Plik " & Cells(i, 1) & ".txt" & " już istnieje. Zamienić plik?", vbYesNo, "Podmiana pliku")
        If czy1 = vbYes Then
            Save2File w, n
            l = l + 1
            GoTo la1
        Else
            GoTo la1
        End If
    End If
    Save2File w, n
    l = l + 1
la1:
Next i
GoTo la2

laend:
nic = MsgBox("Wystąpił jakiś błąd. Sprawdź poprawność danych w wierszu " & i & ".", vbCritical, "Błąd!")

la2:
nic = MsgBox("Zapisano " & l & " pliki(ów).", vbInformation, "Info")

End Sub

Sub Save2File(sText, sFile)
Dim oStream
Set oStream = CreateObject("ADODB.Stream")
With oStream
.Open
.Charset = "utf-8"
.WriteText sText
.SaveToFile sFile, 2
End With
Set oStream = Nothing
End Sub

Public Function dirExists(s_directory As String) As Boolean
Dim oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
dirExists = oFSO.FolderExists(s_directory)
End Function

 

W razie wystąpienia błędu przy zapisie pliku zmień "desktop" na "Pulpit".

Pamiętaj o poprawnych danych w kol. 1 (nazwy plików nie mogą zawierać niektórych znaków specjalnych).


 



#3 Marat

Marat

    Adept

  • Forumowicze
  • Pip
  • 2 Postów:

Napisany 15 lipiec 2017 - 17:47

broda99 - jesteś wielki. Makro działa perfekcyjnie, dokładnie o to chodziło. Naprawdę wielkie dzięki.

Przeanalizuję je sobie w wolnej chwili i porównam z moimi nieudolnymi próbami ;)

Jeszcze raz bardzo dziękuję.



#4 broda99

broda99

    Rozmowny

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

Napisany 15 lipiec 2017 - 22:09

Proszsz..  ;).  Mała poprawka:

n = Environ("USERPROFILE") & "\desktop\" & "test\" & Trim(Cells(i, 1).Value) & ".txt"

 


 






0 Użytkowników czyta ten temat

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