Come scrivo in VBA: per ogni cella contenente “INTERVENTO” cambiagli colore?

Question

Ho una tabella di sette  colonne a righe crescenti che mi viene fornita già compilata. Nella prima colonna (A) riporto le date e  nella colonna E  riporto la descrizione.

Ogni operazione inizia con la descrizione “INTERVENTO” in colonna E e termina dopo un numero variabile di righe con l’ultima con la descrizione in colonna E “INTERVENTO”.

La colonna C è riservata alle entrate, la D alle uscite, la F al risultato economico.

Quando inizio un intervento ho un’uscita di cassa indicata in colonna D, quando lo termino ho un’entrata  indicata in colonna C. Le cifre son tutte positive.

La macro dovrebbe identificare l’inizio di INTERVENTO e colorarlo di rosso ( in questo caso risulta superiore a zero la cella in colonna D e vuota quella in colonna C)

 e la fine di INTERVENTO e colorarlo di verde( in questo caso risulta superiore a zero la cella in colonna C  e vuota quella in colonna D). Vorrei anche riportare il risultato economico nella colonna F nella cella sulla riga di inizio intervento ( somma di colonna C – somma di colonna D di tutti gli importi compresi fra inizio e fine intervento ).

Per ora son qua fermo alla prima domanda non sapendo come definire l’oggetto per usare for each…next.

Ho ben in vista il pollice che indica una direzione  qualsiasi, spero che qualcuno si fermi e mi dia un passaggio perchè se devo farla a piedi non arrivo più.

Answer 1

Ciao barbiturico,

allora se non ci sono altre sorprese una soluzione potrebbe essere questa:

Option Explicit

Private Const mcMod = "Modulo2"

Private Const COL_DATA = 0

Private Const COL_ENTR = 1

Private Const COL_USCI = 2

Private Const COL_RIEC = 3

Private Const COL_DESC = 4

Private Const COL_DATA_NAME = "Data"

Private Const VAL_BEGEND = "Intervento"

Public Sub Test2()

Const cProc = "Test2"

    If StrComp(Application.ActiveCell.Value _

             , COL_DATA_NAME _

             , vbTextCompare) Then

      MsgBox "Questa macro deve essere avviata dalla cella " _

           & "'" & COL_DATA_NAME & "'." _

           , vbOKOnly + vbExclamation _

           , cProc

      Exit Sub

    Else

      Test2Execute Application.ActiveCell

    End If

End Sub

Private Sub Test2Execute(ByVal rng As Excel.Range)

Const cProc = "Test2Execute"

On Error GoTo ErrH

Dim wsh     As Excel.Worksheet

Dim rngData As Excel.Range

Dim rngEntr As Excel.Range

Dim rngUsci As Excel.Range

Dim rngRiEc As Excel.Range

Dim rngDesc As Excel.Range

Dim r       As Long     ' Row

Dim dtmDate As Date

Dim dblTot  As Double

Dim blnEnd  As Boolean

Dim blnTot  As Boolean

    Set wsh = rng.Parent

    Do

      r = r + 1

      With rng

        If IsEmpty(.Offset(r, COL_DATA).Value) Then

          rngRiEc.Value = dblTot

          Exit Do

        End If

        Set rngData = .Offset(r, COL_DATA)

        Set rngEntr = .Offset(r, COL_ENTR)

        Set rngUsci = .Offset(r, COL_USCI)

        Set rngDesc = .Offset(r, COL_DESC)

        If rngDesc.Value = VAL_BEGEND And rngEntr.Value <> "" Then

          rngDesc.Font.Color = vbGreen

          blnEnd = True

          dtmDate = rngData.Value

          Set rngRiEc = .Offset(r, COL_RIEC)

        ElseIf rngDesc.Value = VAL_BEGEND Then

          rngDesc.Font.Color = vbRed

          If blnEnd Then blnTot = True

        Else

          If blnEnd And rngData.Value <> dtmDate Then blnTot = True

        End If

        If blnTot Then

          rngRiEc.Value = dblTot

          Set rngRiEc = Nothing

          If rngEntr.Value <> "" _

             Then dblTot = rngEntr.Value _

             Else dblTot = -rngUsci.Value

          blnEnd = False

          blnTot = False

        Else

          If rngEntr.Value <> "" _

             Then dblTot = dblTot + rngEntr.Value _

             Else dblTot = dblTot - rngUsci.Value

        End If

      End With

    Loop

ExitProc:

    Set rngDesc = Nothing

    Set rngRiEc = Nothing

    Set rngUsci = Nothing

    Set rngEntr = Nothing

    Set rngData = Nothing

    Set wsh = Nothing

    Exit Sub

ErrH:

    MsgBox "ERR#" & Err.Number & vbNewLine & Err.Description _

         , vbCritical + vbOKOnly _

         , mcMod & "." & cProc

    Resume ExitProc

End Sub

Answer 2

Ciao barbiturico,

ancora non ci siamo! Nel tuo esempio hai evidenziato in giallo e verde, alternati, dei blocchi. Suppongo per distinguere una operazione dalla successiva. Se è così allora perché l'operazione che hai colorato in verde, compresa fra le date 26/07 e  02/08, contiene alla riga 14 un "Intervento" che è "Finale" in base alla regola che ci hai esposto nel post del 26/12 dove dicevi che è "Finale" un "Intervento" con Entrate>0? Tanto più che le restanti operazioni sono invece coerenti con le regole che fin qui ci hai esposto. Facci sapere, perché se è solo una svista allora tutto è chiaro e si potrebbe anche procedere con la versione finale.

Cioè, no. Sarebbe da chiarire anche dove mettere le somme. Perché in un primo tempo parlavi di metterle in corrispondenza dell'"Intervento" iniziale, ma poi abbiamo scoperto che di iniziali ce ne sono più di uno. Come la mettiamo? Io proporrei di metterle in corrispondenza dell'"Intervento" finale, ché almeno ce n'è solo uno per operazione. Che dici?

Buon anno! :)

Answer 3

La sto studiando, voglio capire tutto. Scusa se sarò lento nel doveroso riscontro.

Nel frattempo ho imparato a postare i files come suggeritomi da Mauro.

Grazie del passaggio; da quel che ho visto sarei senz'altro rimasto a piedi e forse avrei tentato anche un gesto estremo!

Answer 4

Ciao barbiturico

Se (se!) ho capito un modo potrebbe essere questo:

Option Explicit

Private Const COL_DATA = 0

Private Const COL_BOOH = 1

Private Const COL_ENTR = 2

Private Const COL_USCI = 3

Private Const COL_DESC = 4

Private Const COL_RIEC = 5

Private Const COL_DATA_NAME = "Data"

'Private Const COL_BOOH_NAME = "Boh"

'Private Const COL_ENTR_NAME = "Entrate"

'Private Const COL_USCI_NAME = "Uscite"

'Private Const COL_DESC_NAME = "Descrizione"

'Private Const COL_RIEC_NAME = "Risultato economico"

Private Const VAL_BEGEND = "Intervento"

Public Sub Test()

Const cProc = "Test"

    If Application.ActiveCell.Value = COL_DATA_NAME Then

      TestExecute Application.ActiveCell

    Else

      MsgBox "Questa macro deve essere avviata dalla cella " _

           & "'" & COL_DATA_NAME & "'." _

           , vbOKOnly + vbExclamation _

           , cProc

      Exit Sub

    End If

End Sub

Private Sub TestExecute(ByVal rng As Excel.Range)

Const cProc = "TestExecute"

On Error GoTo ErrH

Dim wsh As Excel.Worksheet

Dim r   As Long

Dim f   As Long

Dim b   As Boolean

    Set wsh = rng.Parent

    Do

      r = r + 1

      With rng

        If IsEmpty(.Offset(r, COL_DATA).Value) Then Exit Do

        If StrComp(.Offset(r, COL_DESC).Value _

                 , VAL_BEGEND _

                 , vbTextCompare) Then

          ' DO NOTHING

        Else

          If b Then

            .Offset(r, COL_DESC).Font.Color = vbGreen

            .Offset(f, COL_RIEC).Value _

              = Application.WorksheetFunction _

                  .Sum(wsh.Range(.Offset(f + 1, COL_ENTR) _

                               , .Offset(r - 1, COL_ENTR))) _

              - Application.WorksheetFunction _

                  .Sum(wsh.Range(.Offset(f + 1, COL_USCI) _

                               , .Offset(r - 1, COL_USCI)))

            b = False

          Else

            .Offset(r, COL_DESC).Font.Color = vbRed

            f = r

            b = True

          End If

        End If

      End With

    Loop

ExitProc:

    Set wsh = Nothing

    Exit Sub

ErrH:

    MsgBox Err.Description

    Resume ExitProc

End Sub

Answer 5

 

Ho ben in vista il pollice che indica una direzione  qualsiasi, spero che qualcuno si fermi e mi dia un passaggio perchè se devo farla a piedi non arrivo più.

Puoi, per favore, postare un file di esempio in Skydrive:

http://windows.microsoft.com/it-IT/skydrive/download

Qui trovi come fare:

http://answers.microsoft.com/it-it/office/forum/officeversion_other-office_install/come-pubblicare-file-ed-immagini-nei-forum-di/00e17579-87b8-404b-9544-efea19cf4b8a

In questo modo non costringi chi vuole aiutarti a dover ricostruire il tuo contesto.

Grazie.