Filtrare scadenze con due condizioni

[BG66]

Ciao a tutti, spero stiate bene!!
La macro nel file mi elenca nel foglio "In scadenza" l'azienda e la tipologia di scadenza verificatasi.
https://www.dropbox.com/scl/fi/i3q4s4gv562xsx2p4yn1g/Scadenze-Forum.xlsm?dl=0&rlkey=qu5jc0rqp3tcf5w8kn8ekntp1

Codice: Seleziona tutto

Sub SCADUTI()

Dim WS1 As Worksheet, WS2 As Worksheet
Dim DB As Variant, Matrix() As Variant
Dim j As Long, nIncr As Long

Set WS1 = Sheets("DB Doc")
Set WS2 = Sheets("In scadenza")

DB = WS1.Range("A2:K" & WS1.Range("K" & Rows.Count).End(xlUp).Row).Value2
WS2.Range("B:C").NumberFormat = "dd/mm/yyyy"
For j = LBound(DB) To UBound(DB)
    Select Case True
        Case DB(j, 10) < Date And DB(j, 11) < Date
            nIncr = nIncr + 1
            ReDim Preserve Matrix(1 To 3, 1 To nIncr)
            Matrix(1, nIncr) = DB(j, 1)
            Matrix(2, nIncr) = DB(j, 10)
            Matrix(3, nIncr) = DB(j, 11)
        Case DB(j, 10) < Date
            nIncr = nIncr + 1
            ReDim Preserve Matrix(1 To 3, 1 To nIncr)
            Matrix(1, nIncr) = DB(j, 1)
            Matrix(2, nIncr) = DB(j, 10)
        Case DB(j, 11) < Date
            nIncr = nIncr + 1
            ReDim Preserve Matrix(1 To 3, 1 To nIncr)
            Matrix(1, nIncr) = DB(j, 1)
            Matrix(3, nIncr) = DB(j, 11)
        Case Else
   
    End Select
Next j

WS2.Range("A2:C" & Rows.Count).ClearContents

If nIncr > 0 Then
    WS2.Range("A2:C" & nIncr + 1).Value = Application.Transpose(Matrix)
End If

Set WS1 = Nothing
Set WS2 = Nothing

End Sub


Ma se volessi ottenere solo le scadenze che rispondono a due condizioni, ossia:
1) scaduto fino a __( cella H2)
2) scegliere quale scadenza voglio analizzare (cella J2)

Grazie per l'aiuto.

[Marius44]

Ciao Gene
ben trovato.

Prova con questa macro (ma dopo aver indicato ciò che vuoi evidenziare nelle celle P2 e Q2 del Foglio "DB Doc")

Codice: Seleziona tutto

Sub SCADUTI_Marius()

Dim WS1 As Worksheet, WS2 As Worksheet
Dim DB As Variant, Matrix() As Variant
Dim j As Long, nIncr As Long
Dim finoa As Double, tipo As String, ur As Long, a As Long

Set WS1 = Sheets("DB Doc")
Set WS2 = Sheets("In scadenza")
finoa = WS1.Cells(2, 16).Value
tipo = WS1.Cells(2, 17).Value
ur = WS1.Cells(Rows.Count, 1).End(xlUp).Row
cn = Application.WorksheetFunction.Match(tipo, WS1.Range("a1:K1"), 0)
WS2.Cells(1, 12) = "Nome Azienda"
WS2.Cells(1, 13) = tipo
a = 1
For i = 2 To ur
  If WS1.Cells(i, cn) <= finoa Then
    a = a + 1
    WS2.Cells(a, 12) = WS1.Cells(i, 1)
    WS2.Cells(a, 13) = WS1.Cells(i, cn)
  End If
Next i
End Sub


Ti scriverà i dati nel Foglio "In Scadenza" colonne L e M

Ciao,
Mario

[BG66]

Ciao Mario,
è sempre un piacere leggerti che per quanto mi riguarda, significa che è tutto ok per Te e la tua famiglia.

Ovviamente il tuo aiuto centra l'obiettivo quindi [RISOLTO].

A presto e STAY SAFE.

Gene
PS mi hai fatto na capa tanta per

Codice: Seleziona tutto

Set WS1 = Nothing
Set WS2 = Nothing

e tu li togli dallo script??

[Anthony47]

Bravo e veloce...

Mi permetto questa variante bivalente, cioe' filtra come la macro originale se H2 e J2 sono vuoti oppure usa quei parametri per il filtro con condizioni aggiuntive; inoltre mantiene l'uso della Matrix per velocizzare le operazioni, cosa che e' utile solo se la tabella di origine e' molto "corposa":

Codice: Seleziona tutto

Sub SCADUTI_XA()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim DB As Variant, Matrix() As Variant
Dim J As Long, nIncr As Long
Dim fDate As Date, fVal As Long, FA As Boolean, FB As Boolean, FC As Boolean
'
Set WS1 = Sheets("DB Doc")
Set WS2 = Sheets("In scadenza")
'
If WS2.Range("H2") = 0 Then fDate = Date Else fDate = WS2.Range("H2").Value
If WS2.Range("J2") = 0 Then
    fVal = 0
Else
    fVal = Application.Match(WS2.Range("J2").Value, WS1.Range("A1:Z1"), False)
End If
'
DB = WS1.Range("A2:K" & WS1.Range("K" & Rows.Count).End(xlUp).Row).Value2
WS2.Range("B:C").NumberFormat = "dd/mm/yyyy"
For J = LBound(DB) To UBound(DB)
    FA = False: FB = False: FC = False
    If fVal = 0 Then
        If DB(J, 10) < fDate Then FA = True
        If DB(J, 11) < fDate Then FB = True
    Else
        If DB(J, fVal) < fDate Then FC = True
    End If
    If FA Or FB Or FC Then
        nIncr = nIncr + 1
        ReDim Preserve Matrix(1 To 3, 1 To nIncr)
        Matrix(1, nIncr) = DB(J, 1)
        If FA Then Matrix(2, nIncr) = DB(J, 10)
        If FB Then Matrix(3, nIncr) = DB(J, 11)
        If FC Then Matrix(fVal - 8, nIncr) = DB(J, fVal)
    End If
Next J
'Scrivi risultati:
WS2.Range("A2:C" & Rows.Count).ClearContents
If nIncr > 0 Then
    WS2.Range("A2:C" & nIncr + 1).Value = Application.Transpose(Matrix)
End If
End Sub


Ciao a tutti

[BG66]

Ciao Anthony,
scusa il riscontro ritardato ma ho cercato di studiare la tua soluzione per capirne il funzionamento.
In pratica ho provato a simulare che i dati delle due scadenze non fossero nelle colonne J e K ( lasciando comunque delle date in quelle colonne) ma M ed O ma anche con i consigli mirati di Mario....non sono riuscito a capire quali parametri sono da correggere.
Mi aiuti a capire?
https://www.dropbox.com/scl/fi/nvji5hibysqr3tzthvt9p/Scadenze-Forum-postAnthony.xlsm?dl=0&rlkey=6vmjyt0bs0cqpuxp60onvhr7p

Grazie se puoi.
Gene

[Anthony47]

In questi giorni non riesco a scaricare files
In prima istanza devi modificare la riga DB = WS1.Range("A2:K" & WS1etc etc per copiare l'intera tabella; poi tieni presente che colonna J corrisponde a DB(J, 10) e colonna K a DB(J, 11), quindi mi pare che debba modificare in DB(J, 13) e DB(J, 14).
La variabile fVal dovrebbe invece adattarsi automaticamente al nuovo tracciato, perche' si allinea con le intestazioni.

Prova con queste informazioni...
Ciao

[BG66]

--

[BG66]

Ciao Anthony,
il debug non ha gradito:




Anche usando 13 per la colonna M e 15 per la colonna O -> rien a faire.
Cosa sbaglio?
https://www.dropbox.com/scl/fi/hwscaoma0uyinqxukyzir/Scadenze-Forum-2.xlsm?dl=0&rlkey=a6s3a044zpukl6yua3nbojyps
Attendo tue
Gene

[Marius44]

Ciao Gene
col permesso del nostro Maestro, modifica la macro come sotto indicato

Codice: Seleziona tutto

Sub SCADUTI_XA()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim DB As Variant, Matrix() As Variant
Dim J As Long, nIncr As Long
Dim fDate As Date, fVal As Long, FA As Boolean, FB As Boolean, FC As Boolean
'
Set WS1 = Sheets("DB Doc")
Set WS2 = Sheets("In scadenza")
'
If WS2.Range("H2") = 0 Then fDate = Date Else fDate = WS2.Range("H2").Value
If WS2.Range("J2") = 0 Then
    fVal = 0
Else
    fVal = Application.Match(WS2.Range("J2").Value, WS1.Range("A1:Z1"), False)
End If
'
DB = WS1.Range("A2:O" & WS1.Range("O" & Rows.Count).End(xlUp).Row).Value2 ' ex k --k
WS2.Range("B:C").NumberFormat = "dd/mm/yyyy"
For J = LBound(DB) To UBound(DB)
    FA = False: FB = False: FC = False
    If fVal = 0 Then
        If DB(J, 13) < fDate Then FA = True
        If DB(J, 15) < fDate Then FB = True
    Else
        If DB(J, fVal) < fDate Then FC = True
    End If
    If FA Or FB Or FC Then
        nIncr = nIncr + 1
        ReDim Preserve Matrix(1 To 3, 1 To nIncr)
        Matrix(1, nIncr) = DB(J, 1)
        If FA Then Matrix(2, nIncr) = DB(J, 13)
        If FB Then Matrix(3, nIncr) = DB(J, 15)
'mia aggiunta e modifica
        If fVal = 13 Then x = 2 Else x = 3
        If FC Then Matrix(fVal - (fVal - x), nIncr) = DB(J, fVal)
'fine mia aggiunta e modifica
   
    End If
Next J
'Scrivi risultati:
WS2.Range("A2:C" & Rows.Count).ClearContents
If nIncr > 0 Then
    WS2.Range("A2:C" & nIncr + 1).Value = Application.Transpose(Matrix)
End If
End Sub


Fai sapere (e speriamo che Anthony non mi prenda a scappellotti). Ciao,
Mario

[Anthony47]

Ora posso scaricare i file...

Nel suggerimento precedente avevo trascurato che Matrix ha tre righe; modificato l'indice di colonna bisogna riallineare colonna M=13 al 2 e colonna O=15 al 3
Cosa che la modifica di Mario fa alla perfezione...

e speriamo che Anthony non mi prenda a scappellotti

E perche' dovrei, io? Al massimo ti becchi 6= (leggasi 6 meno meno) dal professore di Algebra, perche' e' evidente che Matrix(fVal - (fVal - x), nIncr) si semplifica in Matrix(x, nIncr)

Ciao!

[Marius44]

Ciao Anthony



Sono mortificato. Che figura!!!!
Grazie. Ciao,
Mario

[BG66]

Ovviamente un connubio di menti cosi elevato non poteva che raggiungere il target!!!

Grazie mille ad entrambi.

STAY SAFE
Gene

[Anthony47]

Che figura!!!!

Tranquillo, che il voto piu' basso non fa media!

Alla prossima...