adattare cella al contenuto in una cella unita

Question

Buonasera, per mia comodità ho duvuto unire delle celle su un foglio di lavoro Excel. C'è la possibilità di adattare la cella (unita) al contenuto senza dover ogni volta farlo manualmente?

Grazie.

Answer 1

Ciao Roberto,

Buonasera, per mia comodità ho duvuto unire delle celle su un foglio di lavoro Excel. C'è la possibilità di adattare la cella (unita) al contenuto senza dover ogni volta farlo manualmente?

Prova qualcosa del genere:

• Fai clic dx sulla linguetta del foglio di interesse
• Seleziona l'opzione Visualizza Codice dal **** menu contestuale risultante
• Incolla il seguente codice:

'===========>>

Option Explicit

'----------->>

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rCell As Range

    Dim bMerge As Boolean

    For Each rCell In Target.Cells

        If rCell.MergeCells Then

            bMerge = True

            Exit For

        End If

    Next rCell

    If bMerge Then

        Call SetRowHeights(Me, Target)

    End If

End Sub

'<<===========

• Alt+F11 per aprire l'editor di VBA
• Alt+IMper inserire un nuovo modulo di codice
• Nel nuovo modulo vuoto, incolla il seguente codice:

'===========>>

Option Explicit

'----------->>

Public Sub SetRowHeights(Sh As Object, Optional aRng As Range)

'\ ------------------------------------------------------

'\ Vedi:Autofit the row height when there are merged cells

'\ https://answers.microsoft.com/en-us/office/forum/office\_2007-excel/autofit-the-row-height-when-there-are-merged-cells/6d5257a6-6c5d-47ba-991a-3a18f8045039?tab=AllReplies

'\ ------------------------------------------------------

    Dim C As Range, rRow As Range, myRng As Range

    Dim sHeight As Single

    Dim sBestHeight As Single

    Dim bUpdate As Boolean

    Dim bHid As Boolean

    Dim iHidCol As Integer

    Dim cSizer As Range

    bUpdate = Application.ScreenUpdating

    Application.ScreenUpdating = False

    If aRng Is Nothing Then

        Set myRng = Sh.UsedRange

    Else

        Set myRng = aRng

    End If

    If TypeName(Sh) = "Worksheet" Then

        If IsNull(myRng.WrapText) Or myRng.WrapText Then

            Workbooks.Add xlWorksheet

            Set cSizer = Range("A1")

            For Each rRow In myRng.Rows

                If IsNull(rRow.WrapText) Or rRow.WrapText Then

                    If IsNull(rRow.MergeCells) Then

                        rRow.EntireRow.AutoFit

                    Else

                        sBestHeight = 15

                        For Each C In rRow.Cells

                            If C.Address = C.MergeArea.Range("A1").Address _

                               And C.WrapText _

                               And Not C.EntireColumn.Hidden Then

                                cSizer.Value = C.Text

                                cSizer.Font.Size = C.Font.Size

                                cSizer.Font.Bold = C.Font.Bold

                                cSizer.EntireColumn.ColumnWidth = _

                                C.MergeArea.Width * cSizer.ColumnWidth _

                                                                  / cSizer.Width

                                cSizer.WrapText = True

                                cSizer.EntireRow.AutoFit

                                sHeight = cSizer.RowHeight

                                If C.MergeArea.Rows.Count > 1 Then

                                    sHeight = sHeight - _

                                              (C.MergeArea.Rows.Count - 1) _

                                              * (C.Font.Size + 2.75)

                                End If

                            Else

                                sHeight = C.Font.Size + 2.75

                            End If

                            If sHeight > sBestHeight Then sBestHeight = sHeight

                        Next

                        If rRow.EntireRow.RowHeight <> sBestHeight Then

                            rRow.EntireRow.RowHeight = sBestHeight

                        End If

                    End If

                End If

            Next

            ActiveWorkbook.Close False

        End If

    End If

    Application.ScreenUpdating = bUpdate

End Sub

'<<=========== 

• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l’estensione xlsm

===

Regards,

Norman