automatická velikost řádku sloučených buněk
Napsal: 17 pro 2011 15:52
od dolphino
Ahoj,
pokouším se už několik dní přijít na to, jak automaticky přizbůsobit výšku řádku danému textu ve sloučených buňkách.
příklad: slučte tři buňky v jednom řádku, zapište do něj text přesahující velikost vytvořeného okna a potvrďte. i když máte ve formátu zvoleno Zalomení textu, přesto text se nezalomí a řádek nepřizpůsobí.
Z tohoto důvodu bych vás chtěl poprosit, zda-li někdo znáte řešení.
Díky
Petr
Re: automatická velikost řádku sloučených buněk
Napsal: 17 pro 2011 16:30
od cmuch
Ahoj,
ve sloučených buňkách to dělá problémy, tak buď se jich nějak zbav
nebo použij makro Erika Van Geta, které to přizpůsobení textu ve sloučených buňkách udělá za tebe.
Vyber sloučené buňky s dlouhým textem a krokuj makro ať vidíš co dělá.
Kód: Vybrat vše
Option Explicit
Sub fit_height_merged_cells()
'Erik Van Get
'060612
'use only if "center accross selection" is really not an option
Dim rng As Range
Dim MergeArea As Range
Dim FC As Integer
Dim LC As Integer
Dim FCWidth
Dim TotalWidth As Double
Dim i As Integer
Set rng = Selection
Set MergeArea = rng(1).MergeArea
If MergeArea.Address <> rng.Address Or rng.Cells.Count = 1 Then
MsgBox "Please select one MergeArea", 48, "ERROR"
Exit Sub
End If
FC = MergeArea.Column
LC = FC + MergeArea.Columns.Count - 1
FCWidth = Columns(FC).ColumnWidth
For i = FC To LC
TotalWidth = TotalWidth + Columns(i).ColumnWidth
Next i
Application.ScreenUpdating = False
rng.UnMerge
rng(1).ColumnWidth = TotalWidth
rng(1).EntireRow.AutoFit
rng.Merge
Columns(FC).ColumnWidth = FCWidth
Application.ScreenUpdating = True
End Sub
Re: automatická velikost řádku sloučených buněk
Napsal: 18 pro 2011 00:10
od dolphino
fantastické, děkuji Ti mockrát, co mi to dalo.
Re: automatická velikost řádku sloučených buněk
Napsal: 18 pro 2011 11:23
od cmuch
Ještě jsem našel jedno makro,
ale to pracuje jen pokud jsou sloučené buňky na jednom řádku a mají aktivní zalamování řádků.
Kód: Vybrat vše
Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight, MergedCellRgWidth, ActiveCellWidth, PossNewRowHeight As Single
Dim CurrCell As Range
If ActiveCell.MergeCells Then
With ActiveCell.MergeArea
'Jsou sloucene bunky na jednom radku a maji zalamovani textu?
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
Application.ScreenUpdating = True
End Sub