SubTotali Legati ad Una Condizione

[PDAPartecipante PDA]

Ciao a tutti,

con il codice sotto riportato organizzo i dati presenti nei file in allegato così come sono.

Cioè, per valori di F maggiori oppure uguali a zero  viene effettuata una unica somma della colonna J nella colonna K.

Per valori negativi, viene effettuata la somma parziale dei singoli valori,  se diversi tra loro altrimenti raggruppati se uguali.

Ho un problema, però.

Sub InserisciTotali()
Dim uR As Long, iR As Long
Dim Sh As Worksheet
Dim iStart As Long, iEnd As Long
Dim Expire As BooleanApplication.ScreenUpdating = True

Set Sh = ActiveSheet 'NewWK

With Sh
uR = Sh.Range("A" & Rows.Count).End(xlUp).Row
.Sort.SortFields.Clear
.Sort.SortFields.Add _
Key:=Range("F2:F" & uR), _
SortOn:=xlSortOnValues, _
Order:=xlDescending, _
DataOption:=xlSortNormal
With .Sort
.SetRange Range("A1:K" & uR)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

iR = 2
iStart = 2
Do Until Sh.Cells(iR, 6) < = 0
iR = iR + 1
Loop
If iR > 2 Then
iEnd = iR - 1
Expire = Sh.Cells(iR - 1, 6) >= 0
InsertRow iR, iStart, iEnd, Expire
iR = iR + 1
iStart = iR
End If
Do Until Sh.Cells(iR, 6) <> Sh.Cells(iR + 1, 6) Or Sh.Cells(iR, 6) = ""
iR = iR + 1
Loop
iR = iR + 1
iEnd = iR - 1
Expire = Sh.Cells(iR - 1, 6) >= 0
InsertRow iR, iStart, iEnd, Expire
iR = iR + 1
iStart = iR
Do Until Sh.Cells(iR, 1) = ""
Do Until Sh.Cells(iR, 6) <> Sh.Cells(iR + 1, 6)
iR = iR + 1
Loop
iEnd = iR
iR = iR + 1Expire = Sh.Cells(iR - 1, 6) >= 0
InsertRow iR, iStart, iEnd, Expire
iR = iR + 1
iStart = iR
Loop
InsertTotal iR, iR - 2
'Legenda
End With
Set Sh = Nothing
Application.ScreenUpdating = False
End Sub
Private Sub InsertRow(iR As Long, iStart As Long, iEnd As Long, Scaduto As Boolean)
Rows(iR).Insert Shift:=xlDown
Range("J" & iR & ":K" & iR).Font.Bold = True
If Scaduto = True Then
Range("K" & iR).FormulaR1C1 = "=SUM(R[-" & iStart + 1 & "]C[-1]:R[-1]C[-1])"
Range("J" & iR) = "SCADUTO AD OGGI"
Range("J" & iR).Interior.ColorIndex = 8
Range("I" & iR).Interior.ColorIndex = 8
Range("J" & iR).Font.Size = 11
Range("K" & iR).Interior.ColorIndex = 22
Range("K" & iR).NumberFormat = "$ #,##0.00"
Range("K" & iR).Font.Size = 11
ElseIf Scaduto = False Then
Range("J" & iR) = "In scadenza al " & Format(Cells(iEnd, 5), "dd/mm/yyyy")
Else
Range("J" & iR) = "OGGI "
End If
Range("K" & iR).FormulaR1C1 = "=SUM(R[-" & iEnd - iStart + 1 & "]C[-1]:R[-1]C[-1])"
Range("K" & iR).NumberFormat = "$ #,##0.00"End Sub
Private Sub InsertTotal(iR As Long, iStart As Long)
Rows(iR & ":" & iR + 1).Insert Shift:=xlDown
Range("I" & iR + 1 & ":J" & iR + 1).Interior.ColorIndex = 40
Range("I" & iR + 1 & ":K" & iR + 1).Font.Bold = True
Range("I" & iR + 1 & ":K" & iR + 1).NumberFormat = "$ #,##0.00"
Range("I" & iR + 1 & ":K" & iR + 1).Font.Size = 11
Range("J" & iR + 1).HorizontalAlignment = xlRight
Range("J" & iR + 1) = "TOTALE COMPLESSIVO"
Range("J" & iR + 1).Font.Size = 12
Range("K" & iR + 1).FormulaR1C1 = "=SUM(R[-" & iStart & "]C:R[-1]C)"
Range("K" & iR + 1).Interior.ColorIndex = 45
Range("K" & iR + 1).NumberFormat = "$ #,##0.00"
Range("K" & iR + 1).Font.Size = 12
Range("K" & iR + 1).EntireColumn.AutoFit
End Sub

La variabile SCADUTO è di tipo boolean, quindi può essere VERA oppure FALSA, ed è legata alla variabile "giorni di ritardo" che può essere >= a zero oppure <

di zero.
Ho la necessità che assuma invece i tre valori distinti, come nel file ZETA, con la dicitura "In scadenza OGGI".Inoltre, nel file HAKKA, se la somma della colonna K è uguale a zero, allora la dicitura dovrà essere "IMPORTO DA COMPENSARE".Potreste darmi qualche suggerimento?

Spero di si.

Grazie mille.

Saluti,
PDA

[albatros54Moderatore albatros54 Karma: 89 pts]

Ciao PDA, la prossima volta chedevi inserire del codice vai sul pulsante code, si apre una finestra ed inserisci il codice poi click su insert, oggi l'ho fatto io.

Nei file che tua hai allegato non vedo nessun modulo e nessuma macro inserita nei file, cerca di essere piu chiaro.

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente?
( Alan Turing)

[PDAPartecipante PDA]

Ciao Albatros54,

la macro che genera questo file da parte di un progetto (e quindi di un file) molto complesso, per il quale ho già avuto delle tiratine d'orecchie.

Lo allego a questa discussione, cercando di alleggerirlo il più possibile.

Il codice del primo post (InserisciTotali) si trova nel Modulo 9.

Il codice che genera questi file (EstraiFile) si trova  nel Modulo 6 con alla fine il Call al Modulo 9.

Saluti,

PDA

[albatros54Moderatore albatros54 Karma: 89 pts]

Se ho capito nella routine"Sub InserisciTotali()" dichiara la variabile Expire As Long e nella routine"Private Sub InsertRow" la variabile Scaduto As Long.

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente?
( Alan Turing)

[PDAPartecipante PDA]

Ciao Albatros54,

scusami per il ritardo nella risposta.

Ho fatto vari tentativi cercando di seguire il tuo suggerimento, ma non gira come dovrebbe.

Saluti,

PDA

[albatros54Moderatore albatros54 Karma: 89 pts]

Ho la necessità che assuma invece i tre valori distinti, come nel file ZETA, con la dicitura “In scadenza OGGI”.

Nella sub" InserisciTotali()" dichiara la variabile Dim Expire As Long e non a Boolean.

Modifica l'assegnazione alla variabile come sotto.

Expire = Sh.Cells(iR - 1, 6)

in tutta la routine.

Private Sub InsertRow(iR As Long, iStart As Long, iEnd As Long, Scaduto As Long)

in questa dichiara la variabile "Scaduto" long

modifica il codice come sotto

 ElseIf Scaduto < 0 Then
        Range("J" & iR) = "In scadenza al " & Format(Cells(iEnd, 5), "dd/mm/yyyy")
        Else
        Range("J" & iR) = "In scadenza OGGI "
        End If

mentre per il secondo quesito modifica la routine aggiungendo le rige di codice come sotto

If Scaduto > 0 Then
        Range("K" & iR).FormulaR1C1 = "=SUM(R[-" & iStart + 1 & "]C[-1]:R[-1]C[-1])"
        If Range("K" & iR) = 0 Then
        Range("J" & iR) = "importo da compensare"
        Else
        Range("J" & iR) = "SCADUTO AD OGGI"
        End If
        Range("J" & iR).Interior.ColorIndex = 8

fai delle prove e fai sapere, se ho capito

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente?
( Alan Turing)

[PDAPartecipante PDA]

Grande Albatros54.

Questo aspetto è risolto, ma ho notato che nella creazione del file si verifica una strana situazione, come potrai vedere nel file allegato.

In pratica si generano due righe vuote prima del TOTALE COMPLESSIVO (nel caso specifico le righe 7 e 8) e non riesco a capire il perché.

Potresti fornirmi un altro suggerimento?

Grazie mille.

Saluti,

PDA

Allegati:

You must be logged in to view attached files.

[Autore]

Articoli