Funzione CONCATENA, rispettando le formattazioni delle celle d'origine

...

 

Però (c'è sempre un però di mezzo), ti sei dimenticato la originaria richiesta del riporto della eventuale diversa dimensione del carattere (se non ne hai più parlato vuol dire che ciò non è possibile realizzarlo, o mi sbaglio**?**

 

...

Ciao Paolo,

non mi pareva lo avessi chiesto, tant'è che all'inizio della discussione, visto che un pochino ti conosco, ti chiesi:

Un'ultima informazione.

Deve essere 'concatenato' solamente il formato grassetto o anche altre formattazioni?

Non avendo ricevuto risposta, mi sono concentrato solamente sul grassetto. Il nuovo codice, che sostituisce il precedente, 'concatena': il tipo di carattere, la dimensione, il colore, il grassetto, il corsivo e la sottolineatura.

Spero che sia sufficiente. 

Andrea.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rTarget As Range, rSource As Range, cel As Range

Dim sFormula  As String

Dim p As Long, l As Long

  On Error GoTo Uffa

  Set rSource = Range("D8, E8, D9, E9, G9, H9, D10, E10, E11, D12, D5, E5, D6, E6, D7, E7")

  If Intersect(Target, rSource) Is Nothing Then Exit Sub

  Set rTarget = Worksheets("ORD - GDP IND KM").[b11]

  With Application

    .ScreenUpdating = False

    .EnableEvents = False

  End With

  For Each cel In rSource

    sFormula = sFormula & cel.Value

  Next

  rTarget.Value = sFormula

  p = 1

  For Each cel In rSource

    l = Len(cel.Value)

    If l Then

      With rTarget.Characters(p, l)

        .Font.Name = cel.Font.Name

        .Font.Size = cel.Font.Size

        .Font.Color = cel.Font.Color

        .Font.Bold = cel.Font.Bold

        .Font.Underline = cel.Font.Underline

        .Font.Italic = cel.Font.Italic

      End With

    End If

    p = p + l

  Next

exitSub:

  With Application

    .ScreenUpdating = True

    .EnableEvents = True

  End With

  Exit Sub

Uffa:

  Call MsgBox("Si è verificato il seguente errore: " & Err & vbNewLine & Err.Description)

  Resume exitSub

End Sub

Ciao, Andy, 

Ti ringrazio preliminarmente per  avermi fornito l'indirizzo su cui studiare qualcosina  (mi sarebbe servito già ieri**!). Più che il mare, sento nell'aria l'odore del Carnevale di Acireale, luogo in cui vado tutti gli anni, perché lì si respira tutta l'aria "du Brazil".**

 

...

Ciao Paolo,

... peccato solo che manchino le Brasiliane. ;)

Complimenti, comunque, anche questa volta sei riuscito a spingerti oltre i limiti delle funzionalità di excel.

Il problema, come hai giustamente fatto notare tu, si verifica quando la lunghezza del testo risultante eccede i 255 caratteri, è dovuto ad una limitazione della funzione evaluate.

Ti allego il nuovo codice che sostituisce interamente il precedente.

Buon carnevale,

Andrea.

PS:

visto che ti stai applicando per imparare il vba, ti elargisco un primo consiglio:

la prima riga che ho anche evidenziato non è opzionale ma obbligatoriae deve essere presente all'inizio di ogni modulo. Seleziona explicit e premi F1 per informazioni in merito.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rTarget As Range, rSource As Range, cel As Range

Dim sFormula  As String

Dim p As Long, l As Long

On Error GoTo Uffa

Set rSource = Range("D8, E8, D9, E9, G9, H9, D10, E10, E11, D12, D5, E5, D6, E6, D7, E7")

If Intersect(Target, rSource) Is Nothing Then Exit Sub

Set rTarget = Worksheets("ORD - GDP IND KM").[b11]

With Application

.ScreenUpdating = False

.EnableEvents = False

End With

For Each cel In rSource

sFormula = sFormula & cel.Value

Next

rTarget.Value = sFormula

p = 1

For Each cel In rSource

l = Len(cel.Value)

If l Then rTarget.Characters(p, l).Font.Bold = cel.Font.Bold

p = p + l

Next

exitSub:

With Application

.ScreenUpdating = True

.EnableEvents = True

End With

Exit Sub

Uffa:

Call MsgBox("Si è verificato il seguente errore: " & Err & vbNewLine & Err.Description)

Resume exitSub

End Sub