Moderatori: Anthony47, Flash30005
ur = Sheets("Riepilogo").Range("A" & Rows.Count).End(xlUp).Row
For x = ur To 2 Step -1
For y = x - 1 To 2 Step -1
If Len(Trim(Cells(x, 1))) <> 0 Then
If Cells(x, 1) = Cells(y, 1) Then
Sheets("Riepilogo").Range(Cells(y, 1), Cells(y, 6)).Delete
End If
End If
Next y
Next x
Sub deldup()
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
UR = Sheets("Riepilogo").Range("A" & Rows.Count).End(xlUp).Row
For I = UR To 1 Step -1
If Application.WorksheetFunction.CountIf(Cells(I, 1).Resize(UR - I + 1, 1), Cells(I, 1)) > 1 Then _
Sheets("Riepilogo").Cells(I, 1).Resize(1, 6).Delete
Next I
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Anthony47 ha scritto:Ricky! noi abbiamo impiegato anni prima di usare quella tecnica, vuoi che karug in pochi mesi sia in grado di fare la stessa cosa? (senza nulla togliere al valore dei suoi "Maestri"![]()
)
Anthony47 ha scritto:Questa macro usa un algoritmo diverso per identificare i doppioni (la funzione Conta.Se, vs lo scan uno per uno di ogni codice) e soprattutto blocca i ricalcoli, gli eventi e l' aggiornamento dello schermo durante l' esecuzione della macro (riabilitandoli opportunamente a fine macro; vedi le prime 3 e le ultime 3 istruzioni).
'codice di Anthony47
Sub deldup()
Dim nStart As Single
Dim nStop As Single
Dim UR As Long
Dim I As Long
nStart = Timer
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
UR = Sheets("Riepilogo").Range("A" & Rows.Count).End(xlUp).Row
For I = UR To 1 Step -1
If Application.WorksheetFunction.CountIf(Cells(I, 1).Resize(UR - I + 1, 1), Cells(I, 1)) > 1 Then _
Sheets("Riepilogo").Cells(I, 1).Resize(1, 6).Delete
Next I
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
nStop = Timer
MsgBox nStop - nStart
End Sub
'codice di scossa
Sub deldup2()
Dim nStart As Single
Dim nStop As Single
Dim UR As Long
Dim I As Long
Dim cCod As Collection
Dim rng As Range
nStart = Timer
Set cCod = New Collection
UR = Sheets("Riepilogo").Range("A" & Rows.Count).End(xlUp).Row
Set rng = Cells(UR + 1, 1)
On Error Resume Next
For I = UR To 1 Step -1
cCod.Add Cells(I, 1).Value, CStr(Cells(I, 1))
If Err.Number <> 0 Then
Set rng = Union(rng, Cells(I, 1))
Err.Clear
End If
Next I
Intersect(rng.EntireRow, Columns("A:F")).Delete shift:=xlShiftUp
nStop = Timer
MsgBox nStop - nStart
End Sub
karug64 ha scritto:Ciao scossa.
Intanto inizio io.
La tua routine ha prodotto il risultato in 1 sec. rispetto ai 6 sec. della routine di Anthony.
Pero' ha un problema, almeno nei mio caso:
ti accorgerai che la tua routine cancella anche le righe vuote e quelle di inetstazione tra gli anni, mentre quella di Anthony lascia intatta la struttura del foglio ... Si puo' ovviare ?
Anthony47 ha scritto:non so perche', ma a me la macro byScossa non produce effetti significativi, con durata confrontabile con quella della macro originale.
Set MyDict = CreateObject("Scripting.Dictionary
'
'
'
Set rng = Cells(UR + 1, 1).Resize(1, 6)
For I = UR To 1 Step -1
If Not MyDict.exists("" & (Cells(I, 1))) Then
MyDict.Add ("" & Cells(I, 1)), "1"
Else
Set rng = Union(rng, Cells(I, 1).Resize(1, 6))
End If
Next I
rng.Delete shift:=xlShiftUp
scossa ha scritto:Questo comporta che, coi miei dati ci sono solo 8 "errori", quindi "set rng" viene eseguito 8 volte (8 areas in rng); mentre coi tuoi dati si hanno 933 errori con altrettante esecuzioni di "set rng".
Visti i risultati postati da karug, direi che l base dati è simie a quella che ho usato io.
scossa ha scritto:scossa ha scritto:Questo comporta che, coi miei dati ci sono solo 8 "errori", quindi "set rng" viene eseguito 8 volte (8 areas in rng); mentre coi tuoi dati si hanno 933 errori con altrettante esecuzioni di "set rng".
Visti i risultati postati da karug, direi che l base dati è simie a quella che ho usato io.
Ho risposto in fretta e in modo impreciso.
Ora sono di corsa ma poi preciserò meglio.
Set rng = Union(rng, Cells(I, 1))
x = x + 1
If x MOD 40 = 0 Then x = x + 10
Set rng = Union(rng, Cells(UR + x, 1))
Sub deldup2()
Dim nStart As Single
Dim nStop As Single
Dim UR As Long
Dim I As Long
Dim cCod As Collection
Dim rng As Range
Dim x As Long
nStart = Timer
Set cCod = New Collection
UR = Sheets("Riepilogo").Range("A" & Rows.Count).End(xlUp).Row
Set rng = Cells(UR + 1, 1)
On Error Resume Next
For I = UR To 1 Step -1
cCod.Add Cells(I, 1).Value, CStr(Cells(I, 1))
If Err.Number <> 0 Then
x = x + 1
If x Mod 40 = 0 Then x = x + 10
Set rng = Union(rng, Cells(UR + x, 1))
'Set rng = Union(rng, Cells(I, 1))
Err.Clear
End If
Next I
'Intersect(rng.EntireRow, Columns("A:F")).Delete shift:=xlShiftUp
nStop = Timer
MsgBox nStop - nStart & vbCrLf & x & " errori" & vbCrLf & _
rng.Areas.Count & " aree (" & rng.Address & ")"
Set rng = Nothing
End Sub
If Err.Number <> 0 Then
sInd = Cells(I, 1).Address
set rng = range(sInd)
Torna a Applicazioni Office Windows
Stabilire righe e colonne da mostrare a schermo Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 10 |
Eliminare righe diverse dalla prima data del mese Autore: dipdip |
Forum: Applicazioni Office Windows Risposte: 4 |
Codice VBA per stampare UserForm attiva Autore: Carletto Ribolla |
Forum: Applicazioni Office Windows Risposte: 8 |
Aggiungere e eliminare righe senza alterare i riferimenti de Autore: trittico69 |
Forum: Applicazioni Office Windows Risposte: 4 |
cancella righe completamente vuote Autore: trittico69 |
Forum: Applicazioni Office Windows Risposte: 3 |
Visitano il forum: Nessuno e 16 ospiti