Excel - Somma complessiva per "cliente" + somma parziale per "prodotto"

Question

Buongiorno,

il mio problema si rivela essere complesso per le mie limitate conoscenze di VBA e quindi mi risulta anche difficile spiegarlo a parole in modo chiaro (come si vede dall'oggetto che ho messo).

Se è possibile in questa sede, provo a spiegarmi con un paio di immagini.

Siamo in un file excel dove ho due fogli di lavoro: il Foglio1, in cui vengono caricati i dati filtrati dal Foglio2 tramite dei pulsanti di ricerca; il Foglio2, che è quello di inserimento dati.

Il risultato che vorrei ottenere cliccando sul bottone "INSERISCI PER CLIENTI" è il seguente:

Ovvero: totale complessivo, indistintamente dal prodotto, per clienti in rosso e per ogni cliente totali parziali distinti per prodotto in blu.

Usando il codice seguente (da me pasticciato ed è il motivo per cui non funziona correttamente):

(omissis…)

With Worksheets("Foglio1")

Range("A2:E65000").Sort Key1:=Range("C2"), Order1:=xlAscending, Key2:=Range("D2"), Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlAscending, _

Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal

Dim WB As Workbook

Dim sh As Worksheet

Dim sng As Range

Dim rCell As Range

Dim iLastRow As Long

Dim i As Long, j As Long

Dim iCtr As Long

Dim CalcMode As Long

Set WB = ThisWorkbook

Set sh = WB.Sheets("Foglio1")

iLastRow = sh.Cells(Rows.Count, "C").End(xlUp).Row

Set sng = sh.Range("C2:C" & iLastRow)

On Error GoTo XIT

With Application

CalcMode = .Calculation

.Calculation = xlCalculationManual

.ScreenUpdating = False

End With

For i = 1 To sng.Cells.Count

j = j + 1

Set rCell = sng.Cells(j)

With rCell

.Select

iCtr = iCtr + .Offset(0, 2).Value

If .Value <> .Offset(1).Value Then

j = j + 1

.Offset(1).EntireRow.Insert

rCell.Resize(1).Copy Destination:=rCell(2)

rCell(2, 3).Value = iCtr

rCell(2).Resize(1, 3).Font.Bold = True

rCell(2).Resize(1, 3).Font.Color = RGB(255, 0, 0)

iCtr = 0

End If

End With

Next i

XIT:

With Application

.Calculation = CalcMode

.ScreenUpdating = True

End With

Dim WBD As Workbook

Dim shd As Worksheet

Dim sngd As Range

Dim rCelld As Range

Dim diLastRow As Long

Dim di As Long, dj As Long

Dim diCtr As Long

Dim CalcModeD As Long

Set WBD = ThisWorkbook

Set shd = WBD.Sheets("Foglio1")

diLastRow = shd.Cells(Rows.Count, "D").End(xlUp).Row

Set sngd = shd.Range("D2:D" & diLastRow)

On Error GoTo XITD

With Application

CalcModeD = .Calculation

.Calculation = xlCalculationManual

.ScreenUpdating = False

End With

For di = 1 To sngd.Cells.Count

dj = dj + 1

Set rCelld = sngd.Cells(dj)

With rCelld

.Select

diCtr = diCtr + .Offset(0, 1).Value

If .Value <> .Offset(1).Value Then

dj = dj + 1

.Offset(1).EntireRow.Insert

rCelld.Resize(1).Copy Destination:=rCelld(2)

rCelld(2, 2).Value = diCtr

rCelld(2).Resize(1, 2).Font.Color = RGB(0, 0, 255)

diCtr = 0

End If

End With

Next di

XITD:

With Application

.Calculation = CalcModeD

.ScreenUpdating = True

End With

(omissis…)

Ottengo questo risultato:

Che come si vede erroneamente aggiunge una riga di totale "doppio" in grassetto blu, sotto il totale complessivo per cliente in grassetto rosso.

Come modifico il codice (secondo me quello che genera problemi è la parte sottolineata) affinché mi dia il risultato dell'immagine 1?

Scusate il casino, ma non so assolutamente come risolvere.

Grazie a tutti per l'aiuto che vorrete concedermi!

Siete preziosissimi!!!

Marta

Answer 1

Buonasera a tutti!

Dopo numerosissime prove, sono riuscita a risolvere così:

Ho modificato la seguente parte del codice riguardante la somma "parziale" per prodotto (colonna D), da così: 

With rCelld

.Select

diCtr = diCtr + .Offset(0, 1).Value

If .Value <> .Offset(1).Value Then

[omissis]

A così:

With rCelld

.Select

diCtr = diCtr + .Offset(0, 1).Value And .Offset(0, 1).Font.Color <> RGB(255, 0, 0)

If .Value <> .Offset(1).Value And .Font.Color <> RGB(255, 0, 0) Then

[omissis]

Parrebbe funzionare...

Se non mi sentite più vuol dire che ho risolto!

Grazie a tutti!

Marta