Tabulka jako prostý text

Ačkoliv to dnes není tak aktuální jako dříve, stane se, že tabulku Excelu nemůžeme přiložit k e-mailu či příspěvku v diskusní skupině přímo jako sešit či obrazově a jsme odkázáni na prostý text. Oprášil jsem tedy starší článek. Vzorem nám bude obyčejná tabulka na obrázku.

A takto vypadá její převod do prosté textové podoby (okno Immediate editoru VBA):

Správné zarovnání je podmíněné neproporcionálním písmem (zde Courier New), kdy všechny znaky mají stejnou šířku.

Následuje převodní procedura VBA.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82

Sub TabulkaJakoText()

Dim rngOblast As Range
Dim rngSloupec As Range
Dim rngRadek As Range
Dim rngBunka As Range
Dim strRadek As String
Dim strRadekZnaky As String
Dim strRet As String
Dim i As Integer
Dim j As Integer
Dim intPocetRadku As Integer
Dim intPocetSloupcu As Integer
Dim intMaximum As Integer
Dim aPoleDelky()

'znaky oddělovačů
Const cstrBunkaRoh As String = "+"
Const cstrBunkaVer As String = "|"
Const cstrBunkaHor As String = "-"

'přiřazení vybrané oblasti do proměnné
Set rngOblast = Selection

'rozměry oblasti
intPocetRadku = rngOblast.Rows.Count
intPocetSloupcu = rngOblast.Columns.Count

'redimenzování polé s délkami
ReDim aPoleDelky(1 To intPocetSloupcu)

'přiřazení úvodního znaku řádku
strRadekZnaky = cstrBunkaRoh

'pro každý sloupec...
For Each rngSloupec In rngOblast.Columns

i = i + 1

'zjištění maximální délky obsahu buňky ve sloupci
intMaximum = Len(rngSloupec.Cells(1).Text)
For Each rngBunka In rngSloupec.Cells
intMaximum = WorksheetFunction.Max(intMaximum, Len(rngBunka.Text))
Next rngBunka

aPoleDelky(i) = intMaximum

'postupné sestavení řetězce oddělujícího řádku
strRadekZnaky = strRadekZnaky & String(intMaximum, cstrBunkaHor) & _
cstrBunkaRoh

Next rngSloupec

'přiřazení ohraničení shora a úvodního znaku buňky
strRadek = strRadekZnaky & vbCrLf & cstrBunkaVer

'sestavení jednotlivých řádků
For Each rngRadek In rngOblast.Rows
For Each rngBunka In rngRadek.Cells
j = j + 1
'řetězec buňky
strRet = strRet & rngBunka.Text & Space(aPoleDelky(j) - _
Len(rngBunka.Text)) & cstrBunkaVer
Next rngBunka
'řetězec řádku
strRadek = strRadek & strRet & vbCrLf & strRadekZnaky & vbCrLf & _
cstrBunkaVer
'reset proměnných
j = 0
strRet = ""
Next rngRadek

'oříznutí
strRadek = Left(strRadek, Len(strRadek) - 3)

'výpis do okna Immediate (Ctrl+G)
'adresa oblasti
Debug.Print Selection.Address(False, False) & vbCrLf
'textová tabulka
Debug.Print strRadek

End Sub

V programovém kódu si člověk rozhodně vyhraje se slepováním textových řetězců a doplňování do patřičné šířky (funkce String a Space), nicméně nejtěžší část úlohy spočívá ve zjištění nejdelšího obsahu buňky ve sloupci. Stávající řešení se může zdát neefektivní, bohužel moc možností na výběr nemáme. Z buněk potřebujeme přebírat text (formátování ovlivní kupříkladu délku datumu), a nenašel jsem vhodný (maticový) vzorec předaný následně metodě Evaluate. Kód také neřeší sloučené buňky.

V příloze najdete ještě rozšířenou verzi procedury, jež přidává do tabulky hlavičku řádků a sloupců. V jejím provedení jsem již ponechal tabulku zleva a shora neuzavřenou, aby označení řádků a sloupců příliš nesplývalo s vlastním obsahem tabulky.

Tabulka jako prostý text - hlavička — Tabulka jako prostý text – hlavička

Příloha:
tabulka_jako_text.zip

Uložit článek jako PDF