Avatar billede Jann6628 Mester
26. maj 2020 - 11:40 Der er 22 kommentarer og
1 løsning

Auto Fit række højden ved Merged Cells

Hej.

Er det muligt at lave en VBA kode som kan autofitte række højden?

Mit område er B50:H50, hvor den så skal autofit højden på række 50.
Avatar billede thomas_bk Ekspert
26. maj 2020 - 11:45 #1
Jeg bruger denne kode i nogen sammenhænge som du sikkert kan finde inspiration i

Selection.EntireRow.AutoFit
Avatar billede Jann6628 Mester
26. maj 2020 - 11:59 #2
Jeg er desværre ikke så stærk i VBA kodning selv.
Har du mulighed for at komme med den fulde kode (gerne for mit eksempel)?
Avatar billede thomas_bk Ekspert
26. maj 2020 - 12:29 #3
Se gerne om dette fungerer

Sub autofit_rows()

' Tilpasser højden af alle rækker

    Range("B50:H50").EntireRow.AutoFit

End Sub
Avatar billede Jann6628 Mester
26. maj 2020 - 12:31 #4
Desværre.
Avatar billede thomas_bk Ekspert
26. maj 2020 - 12:37 #5
Prøv at indsætte dette i 'immediate window' og kør det.

Range("B50:H50").EntireRow.AutoFit

Fungerer det heller ikke?
Avatar billede Jann6628 Mester
26. maj 2020 - 12:48 #6
Nej desværre.

Hvis du merger A1, B1 og C1.

og så indsætter nedenstående:

hej1
hej2
hej3
hej4
hej5
hej6
hej7


herfra tilpasser excel kun til "hej1"
Avatar billede thomas_bk Ekspert
26. maj 2020 - 12:54 #7
Du skriver at koden skal autofitte på række 50
"område er B50:H50" er også kun række 50.

Er der noget galt dette i det som du skrev så?
Avatar billede Jann6628 Mester
26. maj 2020 - 13:01 #8
#6 var bare et eksempel som var tilsvarende min udfordring.

Det er rigtigt at på mit ark er området "B50:H50" merged.

Altså skal jeg have excel til altid at tilpasse højden til rækken uanset hvor meget brugeren skriver i området.
Avatar billede Jann6628 Mester
26. maj 2020 - 13:04 #9
Normalt kan man jo bare dobbeltklikke på skillelinjen under den række man vil have tilpasset, men det virker ikke når celler i rækken er merged, og at der er flere linjer i de mergede celler.
Avatar billede thomas_bk Ekspert
26. maj 2020 - 13:06 #10
VBA autofit på merged celler er meget kompleks og ud og hvad jeg lige kan klare.
Andre kan sikkert byde ind.

Alternativt er her lidt inspiration
https://contexturesblog.com/archives/2012/06/07/autofit-merged-cell-row-height/
Avatar billede thomas_bk Ekspert
26. maj 2020 - 13:11 #11
Et mulighed du måske skal indtænke i stedet er det der på engelsk hedder 'center across selection'

https://exceljet.net/lessons/how-to-use-center-across-selection-in-excel
Avatar billede Jann6628 Mester
26. maj 2020 - 13:38 #12
God idé.
dog virker den desværre ikke for mig, da jeg stadig ønsker at skriften skal starte fra venstre.
Avatar billede jens48 Ekspert
26. maj 2020 - 13:41 #13
Højreklik på fanebladet og sæt denne makro ind under Koder

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B50:H50")) Is Nothing Then
Target.EntireRow.AutoFit
End If
End Sub
Avatar billede jens48 Ekspert
26. maj 2020 - 13:49 #14
Glem min bemærkning i #12. Det virker ikke ved merged cells
Avatar billede Jann6628 Mester
26. maj 2020 - 14:02 #15
Nej det fandt jeg desværre også ud af.
Avatar billede Mads32 Ekspert
26. maj 2020 - 15:18 #16
Hej jann6628

Hvis du har en linje, som du ønsker der skal tilpasse sig i højde. Skal du undlade at formatere denne. Tilpas cellebredderne til de ønskede bredder. Marker de ønskede celler, og brug ikonet "ombryd tekst". Så vil cellerne tilpasse sig den højeste højde.
Du kan på cellerne  med de formateringer du ønsker.

m v h mads32
Avatar billede thomas_bk Ekspert
26. maj 2020 - 15:27 #17
Jeg har et forslag til en 'work around'

Hvis du i samme række som B50:H50 laver et tilsvarende stort område (eksempelvis J50:P50) som er formatteret med center across selection.
Henvis i J50 til B50.
Gør teksten til hvid så den fremtråder usynlig.

Med center across selection i samme række, så sørger dette for at auto udvide rækkens højde.
Avatar billede Jann6628 Mester
26. maj 2020 - 15:48 #18
#17 - Super god idé Thomas!!

Det virker faktisk. min ud fordring er bare at jeg skal ændre det i 20 workbooks hvor hver workbook har 15 sheets jeg skal gøre det på. (jeg kan desværre ikke bare lave det i én woorkbook og så kopier den, da de andre woorkbooks allerede er i brug af brugerne)

derfor kæmper jeg meget med at bage kunne tilføje til den eksisterende makro.
Avatar billede thomas_bk Ekspert
26. maj 2020 - 16:51 #19
En lille ting, såfremt dine sheets er identiske, så husk at du kan gruppere dem alle og de ændringer du laver i det ene bliver automatisk lavet i alle de andre også.
Så skal du kun igennem processen een gang per workbook.

En anden ting, man kunne jo også skrive en særskilt makro der kan fyres af een gang per workbook som laver ændringerne i mit forslag. Sådan en makro burde faktisk kunne laves via makro optageren.
Avatar billede store-morten Ekspert
26. maj 2020 - 18:43 #20
Er "B50:H50" flettet til en celle?

Flettede celler burde ikke være opfundet ;-)
Avatar billede store-morten Ekspert
26. maj 2020 - 19:47 #21
Celle B50 skal være flette til højre og kun en række (her række 50)
Prøv:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim CurrentRowHeight As Single
Dim MergedCellRgWidth As Single
Dim ActiveCellWidth As Single
Dim PossNewRowHeight As Single
Dim CurrCell As Range

If Not Intersect(Target, Range("B50")) Is Nothing Then

    Range("B50").Select

    If ActiveCell.MergeCells Then
      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 = PossNewRowHeight
            End If
        End With
    End If
End If
    Application.ScreenUpdating = True
End Sub
Avatar billede Jann6628 Mester
27. maj 2020 - 15:49 #22
#21 Du er sku god morten!

Den virker perfekt til mit behov.

Tusinde tak.
Avatar billede store-morten Ekspert
27. maj 2020 - 15:59 #23
Velkommen 😀
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester