Adattare altezza cella (riga) al contenuto.

Question

Salve,

sono sempre impegnato con un modulo per fatture dove in alcune celle (da E30 a E45) devo inserire delle descrizioni dei prodotti che in alcuni casi  si dispongono su più righe e quindi l'altezza standard della riga  di 12.75 non è adeguata a visualizzarne il contenuto.

Le celle da E30 a E45 sono celle unite (in orizzontale - dalla colonna E alla colonna I ) e il dato  è caricato in automatico con la convalida da elenco (è impostato anche l'allineamento/testo a capo).

Avete una macro che dopo l'inserimento dei dati  imposti l'altezza della cella/riga in modo da vedere completamente il contenuto oppure il mio problema si risolve in altro modo?

Vi ringrazio

MF

Answer 1

Ciao MecFala,

ho provato e direi che funziona (però mi ha ridotto la larghezza delle colonne!)

Ti allego il link sui file che ho utilizzato:

https://www.dropbox.com/s/anf13316wr4ohvr/Fatturazione.xlsm?dl=0

https://www.dropbox.com/s/inngg3eytohbj36/FatturazioneBis.xlsm?dl=0

Nel file Fatturazione vedi la situazione iniziale prima della macro.

Nel file fatturazioneBis si vede invece l'azione della macro che mi ha giustificato il testo ma ridotto le colonne.

Ho scaricato i tuoi due file.

Per quanto riguarda la riduzione della la larghezza delle colonne, credo che l'abbia sistemata.

Ho anche notato un potenziale problema con il codice originale: mentre l'altezza della cella sarebbe aumentata per accogliere testo più lungo, se il contenuto di una cella unita fosse sostituito da una stringa di testo più breve, oppure se il testo fosse cancellato, l'altezza della riga si conformerebbe ancora alla precedente testo più lungo. Ora ho risolto questo problema. 

A questo proposito, ho introdotto una costante dAltezzaRigaDefault e il suo valore venga utilizzzata per impostare una altezza minima per il corpo delle fatture. Ho provvisoriamente dato un valore di 20 alla costante per fornire una leggera separazione visiva tra righe contigue nel testo fattura. Si può, naturalmente, sostituire questo valore predefinito con qualsiasi valore alternativo adatto.

Il codice della funzione segue:

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

Option Explicit

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

Public Sub AutoFitMergedCells(Rng As Range)

   Dim rCell As Range, aCell As Range

    Dim rArea As Range

    Dim dCurrentRowHeight As Double

    Dim dMergedCellRngWidth As Double

    Dim dWidth As Double, dPossNewRowHeight As Double

    Dim arrFirstColWidths() As Double

    Dim iCtr As Long, jCtr As Long

    Const dAltezzaRigaDefault As Double = 20 '<<=== Modifica

    Const sFoglioFattura As String = "Fatturazione "                   '<<=== Modifica

    Const sCelleUnite As String = "E30:I44"                                  '<<=== Modifica

    ReDim arrFirstColWidths(1 To Rng.Areas.Count)

    For Each rArea In Rng.Areas

        iCtr = iCtr + 1

        arrFirstColWidths(iCtr) = rArea.Columns(1).ColumnWidth

    Next rArea

    On Error GoTo XIT

    Application.ScreenUpdating = False

    For Each rArea In Rng.Areas

        jCtr = 0

        For Each rCell In Rng.Columns(1).Cells

            With rCell.MergeArea

                If .WrapText = True Then

                    dCurrentRowHeight = dAltezzaRigaDefault

                    .RowHeight = dCurrentRowHeight

                    dWidth = rCell.ColumnWidth

                    For Each aCell In rCell.MergeArea

                        dMergedCellRngWidth = aCell.ColumnWidth _

                                            + dMergedCellRngWidth

                    Next aCell

                    .MergeCells = False

                    .Cells(1).ColumnWidth = dMergedCellRngWidth

                    .EntireRow.AutoFit

                    dPossNewRowHeight = .RowHeight + 5

                    .Cells(1).ColumnWidth = dWidth

                    .MergeCells = True

                    .RowHeight = IIf(dCurrentRowHeight > dPossNewRowHeight, _

                                     dCurrentRowHeight, dPossNewRowHeight)

                    dCurrentRowHeight = 0

                    dWidth = 0

                    dMergedCellRngWidth = 0

                    dPossNewRowHeight = 0

                End If

            End With

        Next rCell

        jCtr = jCtr + 1

        rArea.Columns(1).ColumnWidth = arrFirstColWidths(jCtr)

    Next rArea

XIT:

    Application.ScreenUpdating = True

End Sub

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

Tornando alla procedura Worksheet_Change nel modulo di codice del foglio Fatturazione, ho sostituito il tuo codice:

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

Private Sub Worksheet_Change(ByVal Target As Range)

Tester

End Sub

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

con la seguente versione:

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

Option Explicit

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

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim Rng As Range, rCell As Range

    Dim rngCorpoFattura As Range

    Const sCorpoFattura As String = "E30:I44"

    Set rngCorpoFattura = Me.Range(sCorpoFattura)

    Set Rng = Intersect(rngCorpoFattura.Columns(1), Target)

    If Not Rng Is Nothing Then

        Call AutoFitMergedCells(Rng)

    End If

End Sub

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

Nota, tral'altro, che ho limitato l'avvio della funzione AutoFitMergedCells alla modifica di una o più celle nella intersezione della colonna E con il corpo della fattura, cioè l'intervallo E30:E44. Nel caso della tua versione, il codice sarebbe avviato, spesso inutilmente, in risposta ad una modifica di qualsiasi cella del foglio. Nota anche che,  la mia funzione agisce soltanto sulla riga/righe di interesse.  anzichè l'intero corpo della fattura.

Per quanto riguardo le celle unite in un modello come quello in allegato come avresti risolto la colonna Descrizione senza utilizzarle? 

Io vorrei prendere in considerazione l'uso dell'opzione di allineamento Allinea al centro nelle colonne:

Potresti scaricare il file aggiornato MecFala20151222.xlsm a:

                                     **http://1drv.ms/1TdW4pj**

===

Regards,

Norman

Answer 2

Grazie infinite Norman!

Ottimo lavoro: la macro funziona alla grande e ti ringrazio anche e sopratutto per averne limitato l'esecuzione alle sole celle della "descrizione".

Mi rendo conto che mi è andata bene e di aver ircevuto fin troppo ma per chiudere il modello, se possibile, dovrei con un pulsante salvare il foglio fatturazione  (dopo la compilazione)  in una cartella separata (file xls/xlsm) da salvare nella stessa cartella (directory)  del modello e che abbia (scusa e porta pazienza forse per l'ultima volta) come nome (il file .xls) il NumeroFattura_DataFattura_NomeCliente.

E' una cosa fattibile e/o complicata!?

Non pretendo una soluzione pronta all'uso come quelle che fin ora mi hai mandato (grazie infinite) ma sarebbe sufficiente eventualmente qualche link e/o suggerimento!

Ultima cosa: ho imparato anche l'esistenza di "allinea al centro nelle colonne" che purtroppo non ho mai usato!

Grazie di nuovo per la disponibilità e la competenza.

MF

Answer 3

Salve,

ho provato e direi che funziona (però mi ha ridotto la larghezza delle colonne!)

Ti allego il link sui file che ho utilizzato:

https://www.dropbox.com/s/anf13316wr4ohvr/Fatturazione.xlsm?dl=0

https://www.dropbox.com/s/inngg3eytohbj36/FatturazioneBis.xlsm?dl=0

Nel file Fatturazione vedi la situazione iniziale prima della macro.

Nel file fatturazioneBis si vede invece l'azione della macro che mi ha giustificato il testo ma ridotto le colonne.

Per quanto riguardo le celle unite in un modello come quello in allegato come avresti risolto la colonna Descrizione senza utilizzarle?

Ringrazio di nuovo per la disponibilità e per l'ottima assistenza.

MF

Answer 4

Ti ringrazio per la risposta e per il file in allegato.

Purtroppo  oggi, per motivi di lavoro,  non riesco a verificare quanto mi ha suggerito (forse questa sera) sul mio modello.

Per il momento grazie mille e buona giornata.

MF

Answer 5

Ciao MecFala,

Una ricerca rapida degli archivi di questo forum, usando il mio nome e celle unite come parole chiavi, dovrebbe rapidamente convincerti che io non sono un grande appassionato dell'uso delle celle unite; infatti, personalmente, non le utilizzo mai.

In fatti, il problema che hai riscontato, con la modifica automatica della altezza delle righe,

(Home | Celle ! Formato | Dimensioni celle | Adatta altezza righe), rappresenta solo un motivo tra i tanti per la mia decisione di evitare celle unite!

Detto questo, e non volendo sembrare burbero o brontolone,  prova qualcosa del genere:

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

Option Explicit

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

Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range, rCell As Range, aCell As Range

    Dim dCurrentRowHeight  As Double

    Dim dMergedCellRngWidth As Double

    Dim dWidth As Double, dPossNewRowHeight As Double

    Const sFoglioFattura As String = "Fattura"                               '<<=== Modifica

    Const sCelleUnite As String = "E30:I45"                                     '<<=== Modifica

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglioFattura)

    Set Rng = SH.Range(sCelleUnite)

    On Error GoTo XIT

    Application.ScreenUpdating = False

    For Each rCell In Rng.Cells

        With rCell.MergeArea

            If .WrapText = True Then

                dCurrentRowHeight = .RowHeight

                dWidth = rCell.ColumnWidth

                For Each aCell In rCell.MergeArea

                    dMergedCellRngWidth = aCell.ColumnWidth + dMergedCellRngWidth

                Next aCell

                .MergeCells = False

                .Cells(1).ColumnWidth = dMergedCellRngWidth

                .EntireRow.AutoFit

                dPossNewRowHeight = .RowHeight

                .Cells(1).ColumnWidth = dWidth

                .MergeCells = True

                .RowHeight = IIf(dCurrentRowHeight > dPossNewRowHeight, _

                                 dCurrentRowHeight, dPossNewRowHeight)

                dCurrentRowHeight = 0

                dWidth = 0

                dMergedCellRngWidth = 0

                dPossNewRowHeight = 0

            End If

        End With

    Next rCell

XIT:

    Application.ScreenUpdating = True

End Sub

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

Potresti scaricare il mio file di esempio MecFala20151221.xlsm a:

                                **http://1drv.ms/1JmUYCh**

===

Regards,

Norman