Stránka 1 z 1
Excel - část textu v buňce
Napsal: 10 dub 2014 22:04
od 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!! :)
Re: Excel - část textu v buňce
Napsal: 11 dub 2014 05:40
od cmuch
Do řádku se vejde spousty znaků,
přilož nějakou ukázku se stavem před useknutím a po useknutí.
Re: Excel - část textu v buňce
Napsal: 11 dub 2014 10:37
od 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 :)
Re: Excel - část textu v buňce
Napsal: 11 dub 2014 21:14
od 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
určitě vložit dokážeš.