Calcolo di celle alternate.

Question

Buongiorno a tutti,

vi scrivo in quanto vorrei eliminare le formule nel riquadro ("I1:P19"),("A20:H20"),("Q1:R19"),("Q20:R20") e utilizzare le stesso calcolo ma con il VBA. Nel riquadro I1:P19 ho delle formule che impongono delle condizioni. Esempio: quando in A1 e B1 sono presenti due 1 allora I1 = 1, se C1 o D1 è uguale a 1  allora K1=0 e cosi per tutto il resto. In Q1 effettuo la somma di I,K,M,O e in R1 effettuo la somma di J,L,N,P. In Q20:R20 effettuo la somma delle relative colonne come pure in A20:H20.

Vi allego il file qualora sia stato poco esaustivo nella spiegazione.

https://1drv.ms/x/s!Arlj8dLhPwAFqWNHaXmYuFdPg2EY

Un saluto a tutti e Vi ringrazio in anticipo per l'attenzione.

Answer 1

Ciao Danilo,

vi scrivo in quanto vorrei eliminare le formule nel riquadro ("I1:P19"),("A20:H20"),("Q1:R19"),("Q20:R20") e utilizzare le stesso calcolo ma con il VBA. Nel riquadro I1:P19 ho delle formule che impongono delle condizioni. Esempio: quando in A1 e B1 sono presenti due 1 allora I1 = 1, se C1 o D1 è uguale a 1  allora K1=0 e cosi per tutto il resto. In Q1 effettuo la somma di I,K,M,O e in R1 effettuo la somma di J,L,N,P. In Q20:R20 effettuo la somma delle relative colonne come pure in A20:H20. 

Vi allego il file qualora sia stato poco esaustivo nella spiegazione.

https://1drv.ms/x/s!Arlj8dLhPwAFqWNHaXmYuFdPg2EY

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 Rng As Range, RngDati As Range, rCell As Range

    Dim CellaSommaPari As Range, CellaSommaNonPari As Range

    Dim destCell As Range

    Dim rowSumCell As Range, colSumCell As Range

    Dim i As Long

    Dim iCols As Long, iRows As Long

    Dim dSum As Double, dRowSum As Long, dColSum As Long

    Dim bEven As Boolean

    Const sIntervalloDati As String = "B2:I20"

    Set RngDati = Me.Range(sIntervalloDati)

    Set Rng = Intersect(RngDati, Target)

    If Not Rng Is Nothing Then

        With RngDati

            iCols = .Columns.Count

            iRows = .Rows.Count

            Set CellaSommaNonPari = .Cells(.Row + iRows - 1, _

                                           .Column + iCols * 2 - 1)

            Set CellaSommaPari = CellaSommaNonPari.Offset(0, 1)

        End With

        On Error GoTo XIT

        With Application

            .EnableEvents = False

            .ScreenUpdating = False

            .Calculation = xlCalculationManual

        End With

        For Each rCell In Rng.Cells

            With rCell

                bEven = .Column Mod 2 <> RngDati.Column Mod 2

                Set destCell = .Offset(0, iCols)

                Set rowSumCell = RngDati.Rows(.Row - RngDati.Row + 1).Cells(1). _

                                 Offset(0, iCols * 2 - bEven)

                Set colSumCell = Me.Cells(RngDati.Row + iRows, .Column)

                Select Case True

                Case .Column Mod 2 = RngDati.Column Mod 2

                    dSum = Application.Sum(.Resize(1, 2))

                    If dSum = 2 Then

                        destCell.Value = 1

                    Else

                        destCell.Value = 0

                    End If

                Case Else

                    If dSum = 1 Then

                        destCell.Value = 1

                    Else

                        destCell.Value = 0

                    End If

                End Select

                dColSum = Application.Sum(RngDati.Columns( _

                                          .Column - RngDati.Column + 1))

                For i = 1 To iCols Step 2

                    dRowSum = dRowSum + RngDati.Cells _

                              (.Row - RngDati.Row + 1, 1). _

                              Offset(0, iCols + i - 1 - bEven).Value

                Next i

                rowSumCell.Value = dRowSum

                colSumCell.Value = dColSum

            End With

            dRowSum = 0

            dColSum = 0

        Next rCell

        With RngDati

            CellaSommaPari.Value = _

            Application.Sum(.Columns( _

                            CellaSommaPari.Column - .Column + 1))

            CellaSommaNonPari.Value = _

            Application.Sum(RngDati.Columns( _

                            CellaSommaNonPari.Column - .Column + 1))

        End With

    End If

XIT:

    With Application

        .EnableEvents = True

        .ScreenUpdating = True

        .Calculation = xlCalculationAutomatic

    End With

End Sub

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

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

Questo codice di evento agggiorna la tabella automaticamente in risposta ad una modifica di valori nell'intervallo definito dalle prime 8 colonne e le prime 19 righe della tabella, Volendo, si può modificare le dimensioni della tabella nodificando lòindirizzo assegnato alla costante sIntervalloDati.

Per scattenare il codice per convertire, una tantum, l'intera tabella, seleziona la tabella ed eseguire una semplice operazione di copia/incolla.

Ti chiederei gentilmente di caricare il file problematico, dopo averlo depurato dei dati sensibili, su un servizio di condivisione di file, per esempio Microsoft OneDrive o DropBox, e postare un link al file in una risposta qui.

Potresti scaricare il mio file di prova Danilo23052018.xlsm

===

Regards,

Norman

Answer 2

Ciao Danilo,

Ciao Norman,

GRAZIE per essere intervenuto, ho qualche cosa da chiedere se possibile, c'è qualche altro modo per effettuare il calcolo senza usare il copia incolla della tabella A1:H20, sembra che fino a che non effettuo tale operazione il calcolo non avviene ed in Q20 poi ogni qualvolta aggiungo un 1 nella tabella la somma non sembra essere corretta (il dato precedente viene ricalcolato) ed in R20 non succede niente, è possibile saltare il passaggio dei calcoli che avvengono in I1:P20?.

Invio i 2 file qual'ora io avvessi sbagliato a copiare il codice.

Ancora Grazie mille.

https://1drv.ms/f/s!Arlj8dLhPwAFqWpkp6KvPQvcvWVm

Innanzitutto, chiedo scusa per il ritardo con cui rispondo ma avendo avuto una settimana molto frenetica, in gran parte dovuta agli impegni di viaggio, purtroppo ho trascurato la tua ultima risposta.  Forse possa esserti di qualche conforto che sei in ottima compagnia: Vladimiro e Nelson (e spero nessun altro!) sono anche stati lasciati in sospeso da me! (-:

Fortunatamente, la soluzione al problema sollevato da te è alquanto facile da implementare!

Sostituisci l'istruzione

      Set CellaSommaNonPari = .Cells(.Row + iRows - 1, _

                                                   .Column + iCols * 2 - 1)

con:

        Set CellaSommaNonPari = .Cells(1).Offset(iRows, iCols * 2)

===

Regards,

Norman

Answer 3

Ciao Danilo,

Grazie per la soluzione, come sempre ECCELLENTE.

Come sempre, Danilo, da parte tua, si riceve sempre una risposta gentilissima!

Alla prossima.

===

Regards,

Norman

Answer 4

Ciao Norman,

Grazie per la soluzione, come sempre ECCELLENTE.

Answer 5

Ciao Norman,

GRAZIE per essere intervenuto, ho qualche cosa da chiedere se possibile, c'è qualche altro modo per effettuare il calcolo senza usare il copia incolla della tabella A1:H20, sembra che fino a che non effettuo tale operazione il calcolo non avviene ed in Q20 poi ogni qualvolta aggiungo un 1 nella tabella la somma non sembra essere corretta (il dato precedente viene ricalcolato) ed in R20 non succede niente, è possibile saltare il passaggio dei calcoli che avvengono in I1:P20?.

Invio i 2 file qual'ora io avvessi sbagliato a copiare il codice.

Ancora Grazie mille.

https://1drv.ms/f/s!Arlj8dLhPwAFqWpkp6KvPQvcvWVm