< návrat zpět

MS Excel


Téma: Převod do TXT rss

Zaslal/a 9.2.2010 10:20

Potřeboval bych pomocí vba provést převod excelovské tabulky do čistě textové podoby .

sloupec A sloupec B => výsledek
====================================
text text
123.45 67.89 123.45,67.89
52.50 -35.8924 52.50,-35.8924
další řádky další řádky
prázdný řádek

Textový soubor musí vypadat, jak uvádím, tj.nesmí se vyskytovat jiné znaky jako třeba uvozovky. Výsledný soubor potřebuji načíst do AutoCaduLT jako demo.
Pokud provedu export dat pomocí uložit jako tak je vše OK, ale při opakování zaznamenaného makra je za textem v prvním řádku čárka.
Snad je to srozumitelné. V programování VBA začínám.

Děkuji za pomoc.

Zaslat odpověď >

#001195
Jeza.m
Ahoj, zkus si dát nástroje -> Makro -> Editor jazyka VB.., tam si pak opět najeď do menu Tools -> Preferences, tam vyber Microsoft Scripting Runtime (knihovna scrrun.dll v system32). Pak potřebuješ soubor export.txt umístěný ve stejné složce jako ten excel, no a nakonec si někde do modulu vlož kód:
Public Sub save_text()
On Error Resume Next
Dim fso As New FileSystemObject
Dim fil As File
Dim ts As TextStream
Dim cesta As String
Dim oddelovac As String
Dim text As String
Dim mb As String
Dim co As String
Dim zaco As String

mb = MsgBox("Nahradit některé znaky?", vbYesNo + vbQuestion, "Dotaz")
If mb = vbYes Then
co = InputBox("Zadej text který chceš nahradit", "Nahradit co", ",")
zaco = InputBox("Zadej nový text", "Nahradit čím", ".")
End If

cesta = ThisWorkbook.Path & "\export.txt"
oddelovac = InputBox("Zadej oddělovací znak buňek", "Oddělovač", " ")

Set fil = fso.GetFile(cesta)
Set ts = fil.OpenAsTextStream(ForWriting)

For rd = 1 To ActiveSheet.UsedRange.Rows.Count
For sl = 1 To ActiveSheet.UsedRange.Columns.Count
If co <> "" Then
If text = "" Then
text = Replace(Cells(rd, sl), co, zaco)
Else
text = text & Replace(oddelovac & Cells(rd, sl), co, zaco)
End If
Else
If text = "" Then
text = Cells(rd, sl)
Else
text = text & oddelovac & Cells(rd, sl)
End If
End If
Next
ts.WriteLine text
text = ""
Next
ts.Close
End Sub


který popisovat zatím nebudu :-)
No a když ho pak spustíš, tak by se ti měl naplnit soubor export.txt se zadaným oddělovačem a případně s nahrazeným textem.

M@citovat
#001196
avatar
Díky, převod funguje dobře. Ten příklad co jsem napsal se nějak rozhodil, ale pochopil jsi dobře. Jen ještě potřebuji, aby za textem, který je v buňce A1 nebyl žádný znak, ani ten, co odděluje buňky. A na konci souboru export.txt se vytvořili 3 prázdné řádky.citovat
#001198
Jeza.m
Ahoj,

kód je skoro stejný, jen jsem přidal podmínku
If rd = 1 And sl = 2
aby v případě, že jsem na řádku 1 a chci zapsat hodnotu ze sloupce 2, tak aby byl vynechán oddělovač.

těsně před koncem kódu jsem přidal
ts.WriteBlankLines (2)
kdy číslo v závorce je počet prázdných řádků (jeden by tam měl být už při zapsání, takže tímto přidám ještě 2).

S pozdravem
M@

Public Sub save_text()
On Error Resume Next
Dim fso As New FileSystemObject
Dim fil As File
Dim ts As TextStream
Dim cesta As String
Dim oddelovac As String
Dim text As String
Dim mb As String
Dim co As String
Dim zaco As String

mb = MsgBox("Nahradit některé znaky?", vbYesNo + vbQuestion, "Dotaz")
If mb = vbYes Then
co = InputBox("Zadej text který chceš nahradit", "Nahradit co", ",")
zaco = InputBox("Zadej nový text", "Nahradit čím", ".")
End If

cesta = ThisWorkbook.Path & "\export.txt"
oddelovac = InputBox("Zadej oddělovací znak buňek", "Oddělovač", " ")

Set fil = fso.GetFile(cesta)
Set ts = fil.OpenAsTextStream(ForWriting)

For rd = 1 To ActiveSheet.UsedRange.Rows.Count
For sl = 1 To ActiveSheet.UsedRange.Columns.Count
If co <> "" Then
If text = "" Then
text = Replace(Cells(rd, sl), co, zaco)
Else
If rd = 1 And sl = 2 Then text = text & Replace(Cells(rd, sl), co, zaco) Else text = text & Replace(oddelovac & Cells(rd, sl), co, zaco)
End If
Else
If text = "" Then
text = Cells(rd, sl)
Else
If rd = 1 And sl = 2 Then text = text & Cells(rd, sl) Else text = text & oddelovac & Cells(rd, sl)
End If
End If
Next
ts.WriteLine text
text = ""
Next
ts.WriteBlankLines (2)
ts.Close
End Sub
citovat
#001200
avatar
Tak to jsem přesně potřeboval !
Mám ale ještě jeden problém. Na PC, kde to potřebuji mě na řádku Set fil = fso.GetFile(cesta) objeví chyba viz příloha. Samozřejmě pokud zruším On Error Resume Next.
Zkoušel jsem to na jiných PC a tam je to OK. Nevím, co mám kde doplnit?
Příloha: jpg1200_hlaska.jpg (31kB, staženo 59x)
1200_hlaska.jpg
citovat
#001201
Jeza.m
Ahoj,

jediné co mě napadá, je zkontrolovat v preferences, jestli tam jsou ty správné knihovny co vidíš na jiných pc.

Jinak mě nic nenapadá :-/

M@citovat

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

On-line nástroje

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Aktivní diskuse

ADO DBF/FoxPro

Barth • 11.8. 17:50

Automaticke vlozenie riadku aj v druhom Zosite

danis • 11.8. 17:28

Macro pro leteckou dopravu

Jiří497 • 11.8. 17:15

Macro pro leteckou dopravu

Nosal • 11.8. 13:00

Macro pro leteckou dopravu

Jiří497 • 11.8. 11:45

Macro pro leteckou dopravu

Nosal • 11.8. 8:14

Macro pro leteckou dopravu

Jiří497 • 10.8. 21:35