automatische macro excel

[Gripmaster]

beste heren,

Bestaat er een automatische macro waarbij mijn celhoogte automatisch wordt aangepast aan de teksthoogte.
Aangezien autofit niet werkt bij samengevoegde cellen vraag ik dit af ?

Zie voorbeeld, zoasl het niet moet.

Alvast bedankt.

 

[spaarie]

Hier heb ik wat gevonden
http://www.mrexcel.com/forum/excel-questions/76182-autofit-row-height-display-wrapped-text.html

Werkt op jouw voorbeeldje in ieder geval...

 

[Gripmaster]

Dit is inderdaad perfect,
Kan ik er voor zorgen dat dit ook automatisch gaat met iets. Bijvoorbeeld, wanneer men op opslaan klikt dat hij de hoogte automatisch aanpast.

 

[spaarie]

Dan zou je in 'ThisWorkbook' een Private Sub Workbook_BeforeSave event moeten maken.

Bijvoorbeeld:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Run AutoFitMergedCellRowHeight 'oftewel je macronaam
End Sub

 

[Gripmaster]

Ik kom er niet uit.

Wanneer ik de code van bovengenoemde site toepas en op macro uitvoeren druk, past hij mijn regels aan op de juiste hoogte.
Wanneer ik zoals Spaarie zegt in Thisworkbook het bovenstaande uitvoer, dan geeft hij een foutmelding.

Mijn VBA klopt dus niet. Wat ik nu heb gedaan is het volgende.

Code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Run AutoFitMergedCellRowHeight()
    Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
    Dim CurrCell As Range
    Dim ActiveCellWidth As Single, PossNewRowHeight As Single
    Dim StartCell As Range, c As Range, MergeRng As Range, Cell As Range
    Dim a() As String, isect As Range, i

    
'Take a note of current active cell
Set StartCell = ActiveCell

'Create an array of merged cell addresses that have wrapped text
For Each c In ActiveSheet.UsedRange
If c.MergeCells Then
    With c.MergeArea
    If .Rows.Count = 1 And .WrapText = True Then
        If MergeRng Is Nothing Then
            Set MergeRng = c.MergeArea
            ReDim a(0)
            a(0) = c.MergeArea.Address
        Else
        Set isect = Intersect(c, MergeRng)
            If isect Is Nothing Then
                Set MergeRng = Union(MergeRng, c.MergeArea)
                ReDim Preserve a(UBound(a) + 1)
                a(UBound(a)) = c.MergeArea.Address
            End If
        End If
    End If
    End With
End If
Next c


Application.ScreenUpdating = False

'Loop thru merged cells
For i = 0 To UBound(a)
Range(a(i)).Select
      With ActiveCell.MergeArea
            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
MergedCellRgWidth = 0
Next i

StartCell.Select
Application.ScreenUpdating = True

'Clean up
Set CurrCell = Nothing
Set StartCell = Nothing
Set c = Nothing
Set MergeRng = Nothing
Set Cell = Nothing

End Sub
End Sub

 

[spaarie]

1. Wanneer je een gehele code in een event zet hoef je niet nog eens de macro zelf aan te roepen met een 'Run' functie.
2. Wanneer je de 'Run' functie gebruikt om een macro aan te roepen laat de '()' - tekens achterwegen.

Hier doet alles het prima...