Sub TabulkaTextoveProDBF()
   
   Dim rngOblast As Range
   Dim rngSloupec As Range
   Dim rngRadek As Range
   Dim rngBunka As Range
   Dim rngBunkaHlavicka As Range
   Dim rngBunkaTest As Range
   Dim Ret As String
   Dim Retezec As String
   Dim RetezecOddel As String
   Dim i As Integer
   Dim j As Integer
   Dim PoleDelkyDBF()
   Dim PoleTypyDBF()

   'nastavení zdroje dat
   Set Oblast = Selection

   PocetRadku = Oblast.Rows.Count
   PocetSloupcu = Oblast.Columns.Count

   ReDim PoleDelky(1 To PocetSloupcu)
   ReDim PoleDelkyDBF(1 To PocetSloupcu)
   ReDim PoleTypyDBF(1 To PocetSloupcu)

   For Each rngSloupec In Oblast.Columns

      t = t + 1

      Set rngBunkaHlavicka = rngSloupec.Cells(1)
      Set rngSloupecData = rngSloupec.Offset(1, 0).Resize(PocetRadku - 1, 1)

      For Each rngBunka In rngSloupec.Offset(1, 0).Resize(PocetRadku - 1, PocetSloupcu).Cells
         'testovací buňka (neprázdná)
         If Not IsEmpty(rngBunka) Then
            Set rngBunkaTest = rngBunka
            Exit For
         End If
      Next rngBunka

      'C ... Character (text)
      If WorksheetFunction.IsText(rngBunkaTest) Then

         'maximální délka (včetně obsahu hlavičky)
         strFormula = "=MAX(LEN(" & rngSloupec.Cells.Address & "))"

         ActiveWorkbook.Names.Add Name:="QP23XXEWQ", RefersTo:=strFormula
         strDelka = CStr(Application.Evaluate("QP23XXEWQ"))
         PoleDelky(t) = strDelka
         PoleTypyDBF(t) = "C"
         PoleDelkyDBF(t) = strDelka
         ActiveWorkbook.Names("QP23XXEWQ").Delete
      End If

      'N ... Numeric (číslo)
      If IsNumeric(rngBunkaTest) And Not IsDate(rngBunkaTest) And Not WorksheetFunction.IsLogical(rngBunkaTest) Then

         'maximální délka (včetně obsahu hlavičky)
         strFormula1 = "=MAX(LEN(" & rngSloupec.Cells.Address & "))"
         'maximální počet číslic za desetinnou čárkou
         strFormula2 = "=MAX(LEN(" & rngSloupecData.Address & "-INT(" & rngSloupecData.Address & ")))-2"

         'vložení vzorce pod název
         ActiveWorkbook.Names.Add Name:="QP23XXEWQ1", RefersTo:=strFormula1
         ActiveWorkbook.Names.Add Name:="QP23XXEWQ2", RefersTo:=strFormula2

         'navrácení délky z pojmenovaného vzorce
         strDelka = Application.Evaluate("QP23XXEWQ1")
         'navrácení počtu desetinných míst z pojmenovaného vzorce
         strPocetDesMist = Application.Evaluate("QP23XXEWQ2")
         
         PoleDelky(t) = strDelka
         PoleTypyDBF(t) = "N"
         PoleDelkyDBF(t) = strDelka & "." & strPocetDesMist
         ActiveWorkbook.Names("QP23XXEWQ1").Delete
         ActiveWorkbook.Names("QP23XXEWQ2").Delete

      End If

      'L ... Logical (logická hodnota)
      If WorksheetFunction.IsLogical(rngBunkaTest) Then
         PoleDelky(t) = Len(rngBunkaHlavicka.Text)
         PoleTypyDBF(t) = "L"
         PoleDelkyDBF(t) = "1"
      End If

      'D ... Date (datum)
      If IsDate(rngBunkaTest) Then
         PoleDelky(t) = WorksheetFunction.Max(Len(rngBunkaHlavicka.Text), 8)
         PoleTypyDBF(t) = "D"
         PoleDelkyDBF(t) = "8"
      End If

      'M ... Memo (tento typ neuvažován)

      RetTypyDBF = RetTypyDBF & PoleTypyDBF(t) & Space(CInt(PoleDelky(t)) - 1) & "|"
      RetDelkyDBF = RetDelkyDBF & PoleDelkyDBF(t) & Space(CInt(PoleDelky(t)) - Len(PoleDelkyDBF(t))) & "|"
   Next rngSloupec

   RetezecTypyDBF = "|"
   RetezecDelkyDBF = "|"

   RetezecTypyDBF = RetezecTypyDBF & RetTypyDBF & vbCrLf
   RetezecDelkyDBF = RetezecDelkyDBF & RetDelkyDBF & vbCrLf

   RetezecOddel = "+"
   'sestavení řetězce oddělujícího řádku
   For i = 1 To PocetSloupcu
      RetezecOddel = RetezecOddel & String(PoleDelky(i), "-") & "+"
   Next i

   RetezecOddel = RetezecOddel & vbCrLf

   'sestavení řetězce z hlavičky tabulky
   RetezecHlavicka = "|"
   For Each Bunka In Oblast.Rows(1).Cells
      n = n + 1
      RetHlavicka = RetHlavicka & Bunka.Text & Space(WorksheetFunction.Max(CInt(PoleDelky(n)), Len(Bunka.Text)) - Len(Bunka.Text)) & "|"
   Next Bunka
   RetezecHlavicka = RetezecHlavicka & RetHlavicka & vbCrLf

   Retezec = "|"

   'sestavení řetězců z obsahové části tabulky
   For Each Radek In Oblast.Offset(1, 0).Resize(PocetRadku - 1, PocetSloupcu).Rows
      For Each Bunka In Radek.Cells
         j = j + 1

         BunkaObsah = Bunka.Text

         If PoleTypyDBF(j) = "L" Then
            If Bunka.Text = "NEPRAVDA" Then
               BunkaObsah = "F"
            ElseIf Bunka.Text = "PRAVDA" Then
               BunkaObsah = "T"
            Else
               BunkaObsah = ""
            End If
            Ret = Ret & BunkaObsah & Space(CInt(PoleDelky(j)) - Len(BunkaObsah)) & "|"
         End If

         If PoleTypyDBF(j) = "N" Then
            BunkaObsah = Replace(Bunka.Text, ",", ".")
            Ret = Ret & Space(CInt(PoleDelky(j)) - Len(BunkaObsah)) & BunkaObsah & "|"
         End If

         If PoleTypyDBF(j) = "D" Then
            BunkaObsah = Format(Bunka, "yyyymmdd")
            Ret = Ret & BunkaObsah & Space(CInt(PoleDelky(j)) - Len(BunkaObsah)) & "|"
         End If

         If PoleTypyDBF(j) = "C" Then
            Ret = Ret & BunkaObsah & Space(CInt(PoleDelky(j)) - Len(BunkaObsah)) & "|"
         End If

      Next Bunka
      Retezec = Retezec & Ret & vbCrLf & "|"
      j = 0
      Ret = ""
   Next Radek

   Retezec = RetezecHlavicka & RetezecTypyDBF & RetezecDelkyDBF & RetezecOddel & Left(Retezec, Len(Retezec) - 3)

   'zobrazení v okně Immediate
   Debug.Print Retezec
   
   'zápis do souboru
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set SouborZapis = fso.OpenTextFile(ActiveWorkbook.Path & "\data1250.txt", _
         2, True, -2)

   With SouborZapis
      .Write Retezec
      .Close
   End With

   strCestaAp = ActiveWorkbook.Path & "\"
   
   'změna disku a složky
   ChDrive "E:\"
   ChDir strCestaAp
   'převod z CP1250 do CP852
   Shell "OKKONV.COM /O data1250.txt /W data852.txt /L"
   'čekání na dokončení příkazu
   Application.Wait (Now + TimeSerial(0, 0, 3))
   'převod do souboru DBF (dBase III, kódování CP852)
   Shell "TXT2DBF.EXE /C0164 /O data852.txt"
   
End Sub