Buona giornata, sputnik_r;
mi sembra di capire che hai risolto ma, perdonami, visto che già avevo eseguito alcuni test, mi permetto di proporti questa alternativa.
Tre Pulsanti
- Visualizza Dataset; consente di visualizzare tutti Record
- Filtra Date duplicate; esegue un Filtro su tutte le date duplicate
- Elimina Date duplicate
Dopo aver attivato il Pulsante "Filtra Date duplicate" inserisci un Flag(un Carattere a tuo piacere) nella Colonna "I" della Data che, successivamente, vuoi eliminare.
A questo punto, attivando il Pulsante "Elimina Date duplicate" consenti, solo ai Colleghi che hai autorizzato, di eliminare le Date selezionate; attualmente la password d'accesso alla Procedura è "123" che, ovviamente modificherai a tuo piacere.
Option Explicit
Const Psw As String = "123"
Sub Visualizza_DataSet()
Dim Nrc As Long
Nrc = Range("B" & Rows.Count).End(xlUp).Row
Columns("B:B").EntireRow.Hidden = False
Cells(2, 2).Select
End Sub
Sub Filtra_Date_duplicate()
Application.ScreenUpdating = False
Dim Nrc As Long, x As Long
Nrc = Range("B" & Rows.Count).End(xlUp).Row
Call Visualizza_DataSet
Range(Cells(4, 1), Cells(Nrc, 1)).EntireRow.Hidden = True
For x = Nrc To 4 Step -1
If Cells(x, 2).Value = Cells(x - 1, 2).Value Then Cells(x, 2).EntireRow.Hidden = False
Next x
Application.ScreenUpdating = True
End Sub
Sub Elimina_Date_duplicate()
Dim Titolo As String, Messaggio As String, Default As String, PswA As String
Titolo = "Protezione Codice ''Elimina Date duplicate" ' Definisce il titolo.
Messaggio = "Per accedere a questa Funzione, devi inserire la Password di autenticazione"
Default = ""
PswA = Application.InputBox(Messaggio, Titolo, Default)
If PswA <> Psw Then
MsgBox "La Password" & Chr(10) & PswA & Chr(10) _
& "non è corretta; chiedi autorizzazione al Responsabile."
End
End If
Application.ScreenUpdating = False
Dim Nrc As Long, x As Long
Call Visualizza_DataSet
Nrc = Range("B" & Rows.Count).End(xlUp).Row
For x = Nrc To 4 Step -1
If Cells(x, 9).Value <> "" Then Cells(x, 2).EntireRow.Delete
Next x
Application.ScreenUpdating = True
End Sub
A disposizione.
Buon fine settimana.
Giuseppe
Windows XP - Excel 2000
Windows 10 - Excel 2013