|
ho buttato giu questo ma ancora non lo provo cosa ne pensi?
Option Explicit
Function EliminaDoppioni()
Dim Area, cl
Dim c As Long, r As Long, n As Integer
Dim myColonna
myColonna = 50 '
With Sheets("usciti")
Set Area = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
End With
With Sheets("presenti")
For r = 2 To 100
For c = 1 To 109 Step 4
For Each cl In Area
If .Cells(r, c) <> "" And .Cells(r, c) = cl.Value Then
Sheets("usciti").Cells(cl.Row, cl.Column).Clear
n = n + 1
End If
Next
Next c
Next r
End With
With Sheets("usciti")
Set Area = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
Area.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlGuess
.Columns(myColonna).Clear
Area.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Cells(1, myColonna), Unique:=True
Application.CutCopyMode = False
.Columns(myColonna).Copy
.Range("a1").PasteSpecial xlPasteAll
Application.CutCopyMode = False
.Columns(myColonna).Clear
End With
MsgBox "Fine elaborazione" & Chr(13) _
& "trovati e cancellati " & n & " nominativi"
End Function
| 
