Excel - část textu v buňce

[Lůjík]

Ahojte :)
ráda bych požádala o radu. Potřebovala bych nějaké makro vázané na tlačítko, které by useklo část textu v buňce. Nestačí mi ale funkce ČÁST, potřebuji, aby useklo celé slovo, které se do řádku nevejde... existuje něco takového? Řekněme, že bych povolila 20 znaků, ale nechci aby mi "ukousl" část slova...
Děkuju za radu!! :)

[Reklama]

[cmuch]

Do řádku se vejde spousty znaků,
přilož nějakou ukázku se stavem před useknutím a po useknutí.

[Lůjík]

Třeba tady... viz buňka C7 - potřebuji tlačítko, které by useklo konec textu v buňce tak, aby zbylo "maintenance of public" ... jde to? :)
Děkuji moc za ochotu :)

[cmuch]

Tady je makro, které by to mohlo splnovat.
Provede se pouze na aktivni bunce, v makru si lze upravit treba pro oblast.

Kód: Vybrat vše

Sub ZkratText()
  'zkraceni vety na cele slova podle sirky sloupce
  'pro aktivni bunku / ne sloucenou !!!!!!!!!!

  Dim rngBunka As Object
  Dim ActRow As Integer, ActClm As Integer
  Dim puvodnitext As String
  Dim puvodnisirkasloupce, novasirkasloupce
  Dim pocetvlozenychznaku As Integer, sirka As Integer, mezera As Integer

  ActRow = ActiveCell.Row
  ActClm = ActiveCell.Column

  Set rngBunka = Cells(ActRow, ActClm)

  puvodnitext = rngBunka.Text

  'je bunka sloucena?
  If rngBunka.MergeCells = True Then
    MsgBox "Bunka nesmi byt sloucena !!", vbCritical, "Error"
    Exit Sub
  Else
    puvodnisirkasloupce = rngBunka.ColumnWidth
  End If

  Application.ScreenUpdating = False

  pocetvlozenychznaku = 1 'pocet znaku v bunce
  novasirkasloupce = 0

  'zruseni zalomeni textu
  rngBunka.WrapText = False

  'projdi text a porovnej jeho sirku s sirkou sloupce
  For sirka = 1 To Len(puvodnitext)

    If puvodnisirkasloupce > novasirkasloupce Then
      With rngBunka
        .Value = Mid(puvodnitext, 1, pocetvlozenychznaku)
        .Columns.AutoFit
        novasirkasloupce = .ColumnWidth

        'posledni mezera
        If Mid(puvodnitext, pocetvlozenychznaku, 1) = " " Then
          mezera = pocetvlozenychznaku
        End If
      End With

      pocetvlozenychznaku = pocetvlozenychznaku + 1
    Else
      rngBunka.Value = Mid(puvodnitext, 1, mezera - 1)
      Exit For
    End If
  Next sirka
  'povoleni zalomeni textu
  rngBunka.WrapText = True
  'nastaveni puvodni sirky
  rngBunka.ColumnWidth = puvodnisirkasloupce

  Application.ScreenUpdating = True
End Sub


Tlačítko určitě vložit dokážeš.