Autotilpas rækker

Du kan altid dobbelt-klikke på de sorte mellemrums-streger i venstre side (eller øverst) af regnearket, og jeg har aldrig haft problemer med at autotilpasse, hverken kolonner eller rækker, heller ikke selvom der er flettede celler i arket.

Jeg skulle nok have forklaret mig lidt bedre.

Autotilpasning skal ske automatisk. Dvs. uden at jeg skal klikke på sorte streger e.l.

Rækkehøjden skal simpelthen tilpasses efter hvor meget der står i de flettede celler.

columns.autofit

rows.autofit

Lige lidt mere forklaring.

Jeg aner ikke lige hvad jeg skal gøre med disse linier.

Sætte dem ind VBA-sammenhæng - evt. i forbindelse med en knap eller evt. anden bestående kodning...

Rows.autofit virker ikke.

Den trækker hver enkelt linie sammen til en linie.

De flerste af rækkerne har tekstombrydning om fylder alt fra 3 til 7 rækker. Det er derfor jeg skal bruge en autotilpasning.

Er der en anden løsning ?

Evt. undgå flettede rækker - men i stedet formater cellen til "Ombryd tekst"

Jeg kan ikke se hvordan jeg "kun" kan bruge "ombryd tekst"

Jeg skal have flere kolonner på tværs at mit tekstområde til bla. tallister.
Så jeg skal have flettede celler.

Prøv evt. at sende et eksempel - pb@supertekst-it.dk

Hello igen

Jeg har fundet nedenstående kode. Umiddelbart ser den ud til at klare tricket.

Jeg vil dog ikke have den til at virke ved worksheet_change men i stdet worksheet activate og deactivate.

Hvordan laver jeg det om ?

Kode i module:
Sub AutoFitMergedCellRowHeight(myActiveCell As Range)
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim OrigMergeArea As Range
Dim CurrCell As Range
Dim myActiveCellWidth As Single, PossNewRowHeight As Single
If myActiveCell.MergeCells Then
Set OrigMergeArea = myActiveCell.MergeArea
With myActiveCell.MergeArea
If .Rows.count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
myActiveCellWidth = myActiveCell.ColumnWidth
For Each CurrCell In OrigMergeArea
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = myActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
End Sub

Kode i worksheet:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.count > 1 Then Exit Sub

If Target.MergeCells Then
Call AutoFitMergedCellRowHeight(Target)
End If

End Sub

Rem Din fundne Kode i lagt ind i ThisWorkBook:
Rem ===========================================
Sub AutoFitMergedCellRowHeight(myActiveCell As Range)
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim OrigMergeArea As Range
Dim CurrCell As Range
Dim myActiveCellWidth As Single, PossNewRowHeight As Single

    If myActiveCell.MergeCells Then
        Set OrigMergeArea = myActiveCell.MergeArea
        With myActiveCell.MergeArea
            If .Rows.Count = 1 And .WrapText = True Then
                Application.ScreenUpdating = False
                CurrentRowHeight = .RowHeight
                myActiveCellWidth = myActiveCell.ColumnWidth
                For Each CurrCell In OrigMergeArea
                    MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
                Next
               
                .MergeCells = False
                .Cells(1).ColumnWidth = MergedCellRgWidth
                .EntireRow.AutoFit
                PossNewRowHeight = .RowHeight
                .Cells(1).ColumnWidth = myActiveCellWidth
                .MergeCells = True
                .RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
                CurrentRowHeight, PossNewRowHeight)
            End If
        End With
    End If
End Sub

I Ark - rev.erkl. er følgende kode indlagt:
===========================================
Dim celle As Range, aktuelleArk
Private Sub worksheet_activate()
    aktuelleArk = ActiveSheet.Name
    justerArkRækker
End Sub
Private Sub Worksheet_Deactivate()
On Error GoTo skip
    ActiveWorkbook.Sheets(aktuelleArk).Activate
    justerArkRækker
skip:
    aktuelleArk = ""
End Sub
Private Sub justerArkRækker()
    antalræk = ActiveCell.SpecialCells(xlLastCell).Row
    For r = 1 To antalræk
        If Cells(r, 3).MergeCells Then
            Cells(r, 3).Select
            ThisWorkbook.AutoFitMergedCellRowHeight ActiveCell
        End If
    Next r
    Cells(1, 3).Select
End Sub

Hej Supertekst

Jeg kan godt se det virker ved Worksheet_activate...godt

Men det virker kun sålænge der kommer flere rækker end man umiddelbart har vist. Hvis man har eks. vist 2 rækker men teksten fylder 5. Så virker denne makro godt.

Hvis man har vist 5 rækker men teksten kun fylder 2, så virker den ikke ???

"Vist" har det noget at gøre med 1/0 i højre kolonne?

Nej det har det ikke.

Hvis der f.eks. er opfyldt 1 kriterie i et andet ark. Så fylder teksten ca. 5 rækker.
Hvis det kriterie ikke er opfyldt, så fylder teksten kun 2 rækker.

Som standard står den til kriteriet ikke opfyldt (dvs. 2 rækker). Ændrer man kriteriet til "opfyldt" aktiverer makroen som autilpasser den fint til 5 rækker.

Ændrer man kriteriet igen så det er "ikke-opfyldt" så kan makroen ikke ændre rækkehøjden ned til 2 rækker igen.

Hvor ændres kriterier?
Er der et eksempel fra tidl. fremsendte filer? - ellers kender du "adressen".

Kriterierne ændres efter om der f.eks. er en eller to ejere i stamdatearket i tidl. fremsendte fil.

Dvs. at teksten i de flettede celler er lavet som formler. Eks. Celle C3="teksten" &hvis(kriterieopfyldt;"noget tekst";"noget andet tekst")

Celle C3 er flettet over flere kolonner.

Lukker

Hej.

Jeg har haft god brug af denne gamle tråd, men havde samme problem med koden, nemlig at den kun justerer rækkerne 'opad', og ikke minimerer rækkehøjden hvis 'current' er større end det man ønsker.
Det virker hos mig, hvis man ændrer koden i Module vedr. rækkehøjde til:
.RowHeight = IIf(CurrentRowHeight <> PossNewRowHeight, _
PossNewRowHeight, CurrentRowHeight)