MS Excel

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ěď >

Jeza.m(9.2.2010 12:21)#001195

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

paveku(9.2.2010 17:15)#001196

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

Jeza.m(9.2.2010 20:11)#001198

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 Subcitovat

paveku(10.2.2010 11:41)#001200

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: jpg

1200_hlaska.jpg (31kB, staženo 63x)

citovat

Jeza.m(10.2.2010 13:02)#001201

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

Téma: Převod do TXT

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje