Spesso capita di controllare se in un archivio .xls ci sono dei duplicati in una certa colonna.
Per risolvere questa necessità, ho creato un componete aggiuntivo che attivato tramite la pressione dei tasti CTRL + d.
Questo componente crea un file di testo .csv con elencate tutte le righe escludendo solo quelleduplicati nella colonna selezionata.
Come sapete i componenti aggiuntivi non hanno interfaccia possono essere avviati in due modi:
1. manualmente con il classico doppio clik.
2. automaticamente copiando il file .xla nella cartella XLSTART normalmente il percorso della cartella è C:\Programmi\Microsoft Office\OFFICE11\XLSTART.
Attribute VB_Name = "Modulo1"
Option Explicit
Public Bo_NumDuplicati As Boolean
Public Bo_DaZero As Boolean
Public Bo_DaUno As Boolean
Sub EliminaDuplicati()
Attribute EliminaDuplicati.VB_Description = "Macro registrata il 11/01/2006 da Calogero Rifici"
Attribute EliminaDuplicati.VB_ProcData.VB_Invoke_Func = "d\n14"
' EliminaDuplicati Macro
' Macro registrata il 11/01/2006 da Calogero Rifici
' Scelta rapida da tastiera: CTRL+d
Dim Archivio(60000, 20)
Dim Presenti(60000, 20)
Dim CU_A As Currency
Dim CU_B As Currency
Dim CU_C As Currency
Dim CU_D As Currency
Dim CU_NoDuplicati As Currency
Dim CU_Record As Currency
Dim CU_Campi As Currency
Dim CU_Riga As Currency '= ActiveCell.Row
Dim CU_Colonna As Currency '= ActiveCell.Column
Dim B_Presente As Boolean
Dim ST_NomePercorso As String
Dim ST_Nomefile As String
Dim ST_Riga As String
ST_NomePercorso = ActiveWorkbook.Path & "\" 'disco e cartella del file analizzato
ST_Nomefile = Replace(Mid(ActiveWorkbook.Name, 1, Len(ActiveWorkbook.Name) - 4), " ", "_")
ST_Nomefile = ST_Nomefile & "_" & Replace(ActiveSheet.Name, " ", "_")
ST_Nomefile = ST_Nomefile & "_" & "_NoDuplicati.csv"
'Nome del file composto dal nome del file .xls + il nome della scheda + _NoDuplicati.csv
ScegliPrametri.Show 'apro la maschera
CU_Riga = ActiveCell.Row
CU_Colonna = ActiveCell.Column
MsgBox " Ricerci i duplicati nella colonna " & CU_Colonna
MsgBox " Creo il file " & ST_Nomefile & " e ci scrivo tutti i dati che compaiono almeno una volta "
For CU_A = 1 To 60000
If ActiveSheet.Cells(CU_A, 1).Value = "" Then
CU_Record = CU_A
Exit For
End If
Next CU_A
For CU_A = 1 To 255
If ActiveSheet.Cells(1, CU_A).Value = "" Then
CU_Campi = CU_A
Exit For
End If
Next CU_A
For CU_A = 1 To CU_Record
For CU_B = 1 To CU_Campi
If IsError(ActiveSheet.Cells(CU_A, CU_B).Value) Then
Archivio(CU_A, CU_B) = "" ' ActiveSheet.Cells(cu_A, cu_B).Value
Else
Archivio(CU_A, CU_B) = ActiveSheet.Cells(CU_A, CU_B).Value
End If
Next CU_B
Next CU_A
CU_D = 0
For CU_A = 1 To CU_Record
B_Presente = True
For CU_B = CU_A - 1 To 1 Step -1
If Archivio(CU_B, CU_Colonna) = Archivio(CU_A, CU_Colonna) Then
B_Presente = False
Exit For
End If
Next CU_B
If B_Presente = True Then
CU_D = CU_D + 1
For CU_C = 1 To CU_Campi
Presenti(CU_D, CU_C) = Archivio(CU_A, CU_C)
Next CU_C
End If
Next CU_A
'-----------------------------------------------------------------------
For CU_A = 1 To 60000
If Presenti(CU_A, 2) = "" Then
CU_NoDuplicati = CU_A
Exit For
End If
Next CU_A
'-------------------------------------------
If Bo_NumDuplicati Then
CU_D = 0
For CU_A = 1 To CU_NoDuplicati
For CU_C = 2 To CU_Record
If Presenti(CU_A, CU_Colonna) = Archivio(CU_C, CU_Colonna) Then CU_D = CU_D + 1
Next CU_C
'If Bo_DaZero = True Then Presenti(CU_A, 0) = CU_D
If Bo_DaUno = True Then
Presenti(CU_A, 0) = CU_D
Else
Presenti(CU_A, 0) = CU_D - 1
End If
CU_D = 0
Next CU_A
End If
Presenti(1, 0) = "Num Duplicati" ' Intestazione colonna Numero Duplicati
'-----------------------------------------------------------------------
If Bo_NumDuplicati Then
'Apro il file .csv e ci scrivo dentro i risultati
Open ST_NomePercorso & ST_Nomefile For Output As #1 ' Apre il file congiungendo il percorso e il numero del file.
CU_C = 0 ' pongo a 0 la variabile "CU_C"
ST_Riga = "" ' azzero la variabile
For CU_A = 1 To CU_NoDuplicati ' Ciclo da 1 a quante righe sono presenti
If Presenti(CU_A, 1) <> "" Then
CU_C = CU_C + 1 ' Aggiungo 1 alla variabile cu_c
ST_Riga = Presenti(CU_A, 0) 'inserisco la prima colonna
ST_Riga = ST_Riga & ";" & Presenti(CU_A, 1) ' inserisco la seconda colonna
For CU_B = 2 To CU_Campi + 1
ST_Riga = ST_Riga & ";" & Presenti(CU_A, CU_B - 1) 'inserisco il resto delle righe.
Next CU_B
End If
Print #1, ST_Riga ' scrivo la variabile nel file di testo .csv .
ST_Riga = "" ' azzero la variabile
Next CU_A
Else
Open ST_NomePercorso & ST_Nomefile For Output As #1 ' Apre il file congiungendo il percorso e il numero del file.
CU_C = 0 ' pongo a 0 la variabile "CU_C"
ST_Riga = "" ' azzero la variabile
For CU_A = 1 To CU_NoDuplicati ' Ciclo da 1 a quante righe sono presenti
If Presenti(CU_A, 1) <> "" Then
CU_C = CU_C + 1 ' Aggiungo 1 alla variabile cu_c
'ST_Riga = Presenti(CU_A, 0) 'inserisco la prima colonna
ST_Riga = Presenti(CU_A, 1) ' inserisco la seconda colonna
For CU_B = 3 To CU_Campi + 1
ST_Riga = ST_Riga & ";" & Presenti(CU_A, CU_B - 1) 'inserisco il resto delle righe.
Next CU_B
End If
Print #1, ST_Riga ' scrivo la variabile nel file di testo .csv .
ST_Riga = "" ' azzero la variabile
Next CU_A
End If
Close #1 ' chiudo il file .csv .
MsgBox " Ho Finito di scrivere il files saluti Calo "
Call OpenTextFileTest(ST_NomePercorso, ST_Nomefile) 'passiamo alla funzione "OpenTextFileTest" il nome del file da aprire.
End Sub
Function OpenTextFileTest(ST_NomePercorso As String, ST_Nomefile As String)
Dim ST_AppVal As String
Dim ST_NomeStringa As String
ST_NomeStringa = "notepad.EXE " & ST_NomePercorso & ST_Nomefile
ST_AppVal = Shell(ST_NomeStringa, 1)
End Function
Option Explicit
Private Sub CommandButton1_Click()
Dim dimmi
dimmi = MsgBox("Sei sicuro?", vbYesNo)
If dimmi = vbNo Then Exit Sub
Bo_NumDuplicati = CheckBox1
Bo_DaZero = OptionButton1.Value
Bo_DaUno = OptionButton2.Value
Unload Me
End Sub
Private Sub CheckBox1_AfterUpdate()
If CheckBox1 Then
OptionButton1.Visible = True
OptionButton2.Visible = True
OptionButton1.Value = False
OptionButton2.Value = True
End If
End Sub
Private Sub UserForm_Initialize()
CheckBox1.Value = False
OptionButton1.Visible = False
OptionButton2.Visible = False
End Sub
Scarica. http://www.rifici.it\public\EliminaDuplicati.xla
?>