Automatische rijhoogte samengevoegde cellen

[radegroot]

Sorry mensen, heb het forum doorzocht maar kan niets vinden over deze specifieke vraag...

Ik heb een sheet waarin ik kolom A en B heb samengevoegd. Deze cellen laat ik vanuit een ander sheet vullen mbv vert.zoeken. De standaard rijhoogte is 15, maar het kan zijn dat er teveel tekens zijn. De rijhoogte zou dan automatisch moeten aanpassen, maar dat werkt volgens mij niet met samengevoegde velden. Als ik bijv. dubbelklik onder de cel, wordt de rijhoogte altijd weer 15(ook al heb ik deze handmatig op 30 gezet). Ook de optie Tab Start > Cellen > Rijhoogte automatisch geeft dit resultaat.

Heeft iemand hier ervaring mee? Kan ik bijv. een macro maken waarin ik per cel tel hoeveel tekens er zijn en obv hiervan de rijhoogte instel? Ik heb echter geen idee hoe ik dat zou moeten doen...

Alvast dank voor de input!

Gr.Raymond

 

[danny147]

Beste radegroot

Plak de volgende formule in ThisWorkbook van de VBA editor. (ALT + F11)

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Application.ScreenUpdating = False
For Each cl In Range("A1:A100")
If Len(cl) < 19 Then
cl.RowHeight = 15
End If
If Len(cl) > 18 And Len(cl) < 41 Then
cl.RowHeight = 30
End If
If Len(cl) > 40 Then
cl.RowHeight = 45
End If
Next
Application.ScreenUpdating = True
End Sub

Groetjes Danny. :thumb:

 

[trucker10]

@ Danny , deze aanvulling nog

With Range("A1:A100")
.WrapText = True
End With

te zetten onder de next

 

[Warme bakkertje]

Of enkel de gevulde cellen (bereik beperkt houden)

Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
For Each cl In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
Select Case Len(cl)
    Case Is < 19
        cl.RowHeight = 15
    Case 19 To 40
        cl.RowHeight = 30
    Case Is > 40
        cl.RowHeight = 45
End Select
Next
[A1:A100].WrapText = True
Application.ScreenUpdating = True
End Sub

 

[radegroot]

Thankz guys, dit werkt als een bus. :thumb:

Maar al werkende realiseer ik me dat de velden soms ook gevuld worden met opsomlijstje, bijv.

bla bla bla bla
bla:
- opmerking 1
- opmerking 2
- opmerking 3

In zo'n geval is het aantal tekens bijv. wel tussen de 18 en 41, maar moet de rijhoogte niet 30 maar (5 x 15 =) 75 worden

Zie met name cel A3 in het (nieuwe) voorbeeld.

Alvast weer dank!

Gr.Ray

Ps. is dit volgens de forumregels een nieuw topic?

 

[trucker10]

radegroot , probleem is je samengevoegde cellen , anders had ik een redelijke oplossing voor je .
Maar misschien weet Rudi :thumb: Warme bakkertje dit aan te pakken ( omzeilen MergeCells = True ) anders met deze code enkel op kolom A

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Columns("A:B").ColumnWidth = 12.5
        With Range("A1:A100")
            .WrapText = True
        End With
        
Application.ScreenUpdating = False
    For Each c In Range("A1:A100")
        If c.WrapText = True Then
             c.EntireRow.AutoFit
                Else
             c.RowHeight = 15
        End If
    Next c
Application.ScreenUpdating = True

End Sub

[ edit ] : even google gebruikt en kwam deze code van Greg Wilson tegen :thumb:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range
Dim ma As Range

With Target
If .MergeCells And .WrapText Then
Set c = Target.Cells(1, 1)
cWdth = c.ColumnWidth
Set ma = c.MergeArea
For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next
Application.ScreenUpdating = False
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.EntireRow.AutoFit
NewRwHt = c.RowHeight
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
Application.ScreenUpdating = True
End If
End With
End Sub