[EXCEL/VBA] Rijhoogte samengevoegde cellen automatisch

[Frituurman]

Wederom een vraag van mij. De rapportage die uit mijn Excelletje komt, ziet er goed uit, maar wat vervelend is, is dat er samengevoegde cellen zijn die daarnaast nog eens gevuld zijn met samengevoegde teksten. Nou, op zich niet vervelend, ware het niet dat je niet zomaar een rijhoogte automatisch kunt aanpassen met samengevoegde cellen. Doe je dat namelijk, dan wordt de rijhoogte automatisch op één rijhoogte gezet. En dat staat natuurlijk niet mooi als je meerdere regels in één cel hebt.

Gelukkig is het internet daar en jawel, er is een macro voor:

code:

Sub FixMerged() 'Excel VBA to autofit merged cells
Dim mw As Single
Dim cM As Range
Dim rng As Range
Dim cw As Double
Dim rwht As Double
Dim ar As Variant
Dim i As Integer

Application.ScreenUpdating = False
'Cell Ranges below, change to suit.
ar = Array("A1", "A2", "A3", "A5", "A6")

For i = 0 To UBound(ar)
On Error Resume Next
Set rng = Range(Range(ar(i)).MergeArea.Address)
rng.MergeCells = False
cw = rng.Cells(1).ColumnWidth
mw = 0
For Each cM In rng
cM.WrapText = True
mw = cM.ColumnWidth + mw
Next
mw = mw + rng.Cells.Count * 0.66
rng.Cells(1).ColumnWidth = mw
rng.EntireRow.AutoFit
rwht = rng.RowHeight
rng.Cells(1).ColumnWidth = cw
rng.MergeCells = True
rng.RowHeight = rwht
Next i
Application.ScreenUpdating = True
End Sub

Nu is het probleem dat er hier met een Array wordt gewerkt. Zoals ik het zie kan ik hier niet zomaar een range invullen (dat werkt in elk geval niet. Op het interwebs lees ik dan dat ik dit moet vervangen:

code:

Dim ar As Variant

ar = Array("A1", "A2", "A3", "A5", "A6")

Door:

code:

Dim Ar As Variant 
Ar = Range("A1:A6")

Maar dat haalt werkelijk niets uit; sterker nog, het script doet het dan helemaal niet meer.

Excuses voor alle vragen, maar terwijl ik de ene vraag even parkeer, ga ik weer met het andere 'probleem' aan de slag.

[m-vw]

Twee vragen:

1. Kan je ergens een plaatje delen van je lay-out, want ik snap niet wat je bedoelt.
2. Waarom zou je geen:

Visual Basic:

ar = Array("A1", "A2", "A3", "A4", "A5", "A6")

Kunnen gebruiken?

[Frituurman]

Als je een samengevoegde cel hebt met bijvoorbeeld 3 regels tekst en automatische rijhoogte toepast, wordt de rijhoogte automatisch 1 regel. Automatische rijhoogte werkt niet op samengevoegde cellen.

EDIT1: Ik heb het even in een GIFje gevat:

DUIDING: Wat je hierboven ziet is een samengevoegde cel met 2 regels aan tekst die ik met 'automatische rijhoogte' wil instellen. Wat gebeurt is dat de rijhoogte niet correct wordt aangepast. Excel maakt er onterecht één regel van. Als ik het nalees op internet is dit al sinds het begin van Excel zo. Helaas zitten wij op kantoor aan Excel vast, dus ik zal het er mee moeten doen. Het VBA-Script is handig en zorgt voor de correcte rijhoogte, maar het is erg veel werk om alle individuele cellen hier in te zetten.
EDIT2: Verontschuldingen voor de GIF, maar we hebben geen screen recorder geïnstalleerd staan op onze W10-laptops. Ik moest het dus filmen met de telefoon, omzetten naar een GIF en weer uploaden. Er is behoorlijk wat geschok én het is hevig gecomprimeerd, maar volgens mij is het wel duidelijk zo!

De reden dat ik niet cel voor cel dit wil doen, is dat het gaat om pakweg 200 cellen / regels. Daar wordt de code niet mooier van en het is erg veel werk. Ik heb het vermoeden dat het makkelijker zou moeten kunnen. Maar ik heb geen idee hoe!

[ Voor 56% gewijzigd door Frituurman op 18-10-2018 08:13 ]

[BertS]

Dit is wel een leuke vingeroefening. Volgens mij doet het originele script ook niet helemaal wat het moet doen (maar maakt hij rijen hoger dan nodig).

Onderstaande doet het op Sheet1.UsedRange ipv array (zie regel 13).
Hij zal nog stuk gaan als je in een rij meerdere merged cells hebt, of overlappend (B1:B2 en C2:C3 gemerged zal mis gaan), maar dan heb jij ook nog wat om te fixen

code:

Sub FixMerged() 'Excel VBA to autofit merged cells
  Dim mw As Single
  Dim cM As Range
  Dim rng As Range
  Dim cw As Double
  Dim rowHeight As Double
  Dim cell As Range
  
  Application.ScreenUpdating = False
  
  'Cell Ranges below, change to suit.
  
  For Each cell In Sheet1.UsedRange
    On Error Resume Next
    
    If cell.MergeArea.Address <> cell.Address Then ' only merged cells
      Debug.Print cell.MergeArea.Address
      Set rng = Range(cell.MergeArea.Address)
      rng.MergeCells = False
      
      cw = rng.Cells(1).ColumnWidth
      mw = 0
      
      For Each cM In rng
        cM.WrapText = True
        mw = cM.ColumnWidth + mw
      Next
      
      mw = mw + rng.Cells.Count * 0.66
      rng.Cells(1).ColumnWidth = mw
      rng.EntireRow.AutoFit
      rowHeight = rng.Cells(1).rowHeight ' needed height
      
      Dim rowIndex As Long
      For rowIndex = 2 To rng.Rows.Count  ' height of other rows in merged range
        rowHeight = rowHeight - rng.Rows(rowIndex).Height
      Next rowIndex
      
      rng.Cells(1).ColumnWidth = cw
      rng.MergeCells = True
      rng.Cells(1).rowHeight = rowHeight
    End If
  Next cell
  
  Application.ScreenUpdating = True
End Sub

[Frituurman]

Hoi! Ik heb je script gebruikt in een lege excel op Sheet1 en ik krijg dan een 424 - Object vereist-melding op onderstaande regel:

code:

  For Each cell In Sheet1.UsedRange

Wat doe ik verkeerd?

Ter verduidelijking: In mijn sheet waar ik mee wil werken heb ik meerdere merged cells, maar nooit meer dan één op een regel. Ik heb ook alleen cellen gemerged op één regel met verschillende kolommen (Dus A3:C3), maar niet verspreid over meerdere regels (A1:A3). Dus als ik jou begrijp zou dit juist wel goed moeten gaan.

[ Voor 44% gewijzigd door Frituurman op 18-10-2018 09:48 ]

[m-vw]

Bij mij werkt het originele script wel goed. Enkel samengevoegingen over meerdere regels gaan niet goed.

Ook zou je als A1:C1 uit vier tekstregels bestaat en E1:G1 uit twee eerst E1:G1 moeten laten uitvoeren anders wordt de hoogte van A1:C1 weer verkeerd ingesteld. Natuurlijk kan je dan ook kiezen om E1:G1 niet te verwerken.

Ik snap niet goed waarom @Frituurman niet met het originele script uit de voeten kan.

Als je op regel 13 de cellen aanpast moet het werken. Belangrijk is dan dat je voor A1:C1 A1 op geeft en voor C4:E4 C4. Dus niet de hele samengevoegde range, maar de linkercel.

[Frituurman]

m-vw schreef op donderdag 18 oktober 2018 @ 12:53:
Bij mij werkt het originele script wel goed. Enkel samengevoegingen over meerdere regels gaan niet goed.

Ook zou je als A1:C1 uit vier tekstregels bestaat en E1:G1 uit twee eerst E1:G1 moeten laten uitvoeren anders wordt de hoogte van A1:C1 weer verkeerd ingesteld. Natuurlijk kan je dan ook kiezen om E1:G1 niet te verwerken.

Ik snap niet goed waarom @Frituurman niet met het originele script uit de voeten kan.

Als je op regel 13 de cellen aanpast moet het werken. Belangrijk is dan dat je voor A1:C1 A1 op geeft en voor C4:E4 C4. Dus niet de hele samengevoegde range, maar de linkercel.

Je hebt het nu over het originele script wat ik heb gepost? Dat werkt inderdaad prima, dat is het punt ook niet, maar ik zou graag een range willen opgeven in plaats van individuele cellen. De reden hiervoor is, hoe meer ik het in kaart breng, ontzettend veel cellen zou moeten benoemen (het rapport heb ik inmiddels uitgebreid en betreft meer dan 800 regels, dus ik zou in de array 800 celnummers moeten overtikken; ik dacht dat dit makkelijker zou moeten kunnen).

[m-vw]

Dan is UsedRange inderdaad handiger.

Ontbrekend object kan naar het tabblad verwijzen. Gebruik je de engelse versie of de nederlandse? Geen idee hoe Blad1 achter de schermen wordt genoemd in VBA.

[Frituurman]

En zoals altijd is de oplossing makkelijker dan gedacht. Op één of andere manier werd Sheet1 niet herkend (of Blad1 of Rapportage, zoals het werkblad bij mij heet), dus heb ik het opgelost door te verwijzen naar het huidige werkblad (hier zit ook de trigger om het script af te trappen). Dit heb ik gedaan door deze regel te veranderen:

code:

  For Each cell In Sheet1.UsedRange

In:

code:

  For Each cell In ActiveSheet.UsedRange

De volledige code is nu:

code:

Sub FixMerged()
  Dim mw As Single
  Dim cM As Range
  Dim rng As Range
  Dim cw As Double
  Dim rowHeight As Double
  Dim cell As Range
  
  Application.ScreenUpdating = False

  For Each cell In ActiveSheet.UsedRange ' Het gaat hier om de huidige, actieve worksheet
    On Error Resume Next
    
    If cell.MergeArea.Address <> cell.Address Then ' alleen samengevoegde cellen!
      Debug.Print cell.MergeArea.Address
      Set rng = Range(cell.MergeArea.Address)
      rng.MergeCells = False
      
      cw = rng.Cells(1).ColumnWidth
      mw = 0
      
      For Each cM In rng
        cM.WrapText = True
        mw = cM.ColumnWidth + mw
      Next
      
      mw = mw + rng.Cells.Count * 0.66
      rng.Cells(1).ColumnWidth = mw
      rng.EntireRow.AutoFit
      rowHeight = rng.Cells(1).rowHeight ' needed height
      
      Dim rowIndex As Long
      For rowIndex = 2 To rng.Rows.Count  ' height of other rows in merged range
        rowHeight = rowHeight - rng.Rows(rowIndex).Height
      Next rowIndex
      
      rng.Cells(1).ColumnWidth = cw
      rng.MergeCells = True
      rng.Cells(1).rowHeight = rowHeight
    End If
  Next cell
  
  Application.ScreenUpdating = True
End Sub

Let wel, deze oplossing werkt dus niet bij overlappende samengevoegde cellen (A1:A3 i.c.m. B2:B4 bijvoorbeeld) of meerdere samengevoegde cellen op één regel. Voor mij werkt deze oplossing echter prima!

Dank voor alle hulp wederom!

[ Voor 3% gewijzigd door Frituurman op 18-10-2018 13:23 ]

[EdKoF]

Voor al diegenen die minder handig zijn met VBA:

https://www.asap-utilitie...utilities-free.php?file=1

(gratis voor thuisgebruik)