Valutazione 4.87/ 5 (100.00%) 5838 voti

Condividi:        

[Excel] rimuovi duplicati in "orizzontale"

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

Re: [Excel] rimuovi duplicati in "orizzontale"

Postdi Anthony47 » 07/02/14 02:02

Questa versione dovrebbe essere piu' veloce della precedente; produce pero' lo stesso tipo di file di output: non avendo ancora capito che cosa non quadra sui risultati ottenuti ho preferito non toccare per ora l' impostazione principale.
Codice: Seleziona tutto
Sub Roxx11()
Dim I As Long, J As Long, JJ As Long, OutSh As String, myArea As Range, aaaZ, aaaX, aaaC
'
OutSh = "PIPPO"      '<< Foglio di uscita; vedi testo
'
myTim = Timer
If ActiveSheet.Name = OutSh Then
    MsgBox ("Selezionare il foglio di partenza e ripetere")
    Exit Sub
End If
Set myArea = ActiveSheet.UsedRange
aaaC = myArea.Columns.Count / 1

Sheets(OutSh).Cells.ClearContents
For I = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    For J = 1 To Cells(I, Columns.Count).End(xlToLeft).Column
    aaaX = Cells(I, J).Value
    aaaZ = Application.WorksheetFunction.CountIf(myArea, aaaX)
        If aaaZ > 1 Then
            If aaaZ > Application.WorksheetFunction.CountIf(Cells(I, 1).Resize(1, aaaC), aaaX) _
               And Application.WorksheetFunction.CountIf(Sheets(OutSh).Cells(I, 1).Resize(1, J), aaaX) = 0 Then
                Sheets(OutSh).Cells(I, J).Value = aaaX
            End If
        Else
            Sheets(OutSh).Cells(I, J).Value = aaaX
'            JJ = JJ + 1
        End If
    DoEvents
    Next J
DoEvents
'If I > 100 Then Exit For
Next I
'MsgBox (Timer - myTim)
End Sub

Ciao
Anthony
Win7 + Office 2010 Ita; Win 7 + Office 2013 Ita
Xp + Office 2003 Ita
E voi cosa usate? (per istruzioni vedere viewtopic.php?f=26&t=97449)
Avatar utente
Anthony47
Moderatore
 
Post: 13894
Iscritto il: 21/03/06 16:03
Località: Ivrea

Sponsor
 

Re: [Excel] rimuovi duplicati in "orizzontale"

Postdi c_ros » 10/02/14 11:23

Ciao e grazie per il vari suggerimenti ma ancora non riesco ad ottenere la tabella nel modo che vorrei....
Ho provato ad utilizzare la funzione suggerita da ninai e funziona ma data la quantità di dati non posso utilizzarla.
Anthony ho seguito le tue istruzioni, sostituendo nella macro
Sheets(OutSh).Cells(I, JJ).Value = Cells(I, J)
JJ = JJ + 1
con
Sheets(OutSh).Cells(I, J).Value = Cells(I, J)
ma il file di output "PIPPO" risulta incompleto
Inoltre mi sono resa conta che sarebbe meglio ottenere i vari valori una colonna dopo l'altra e non nella posizione in cui erano nel foglio sorgente.

Ti ringrazio per la pazienza e la disponibilità!

Ciao
c_ros
Utente Junior
 
Post: 24
Iscritto il: 06/01/14 19:39

Re: [Excel] rimuovi duplicati in "orizzontale"

Postdi Flash30005 » 10/02/14 11:50

La specifica iniziale (che infatti non approvavo) era di riportare i dati come erano posti nel foglio origine
Comunque con una semplice modifica della macro di Anthony dovresti ottenere le colonne senza spazi
Codice: Seleziona tutto
Sub Roxx11B()
Dim I As Long, J As Long, JJ As Long, OutSh As String, myArea As Range, aaaZ, aaaX, aaaC
'
OutSh = "PIPPO"      '<< Foglio di uscita; vedi testo
'
myTim = Timer
If ActiveSheet.Name = OutSh Then
    MsgBox ("Selezionare il foglio di partenza e ripetere")
    Exit Sub
End If
Set myArea = ActiveSheet.UsedRange
aaaC = myArea.Columns.Count / 1

Sheets(OutSh).Cells.ClearContents
For I = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    For J = 1 To Cells(I, Columns.Count).End(xlToLeft).Column
    aaaX = Cells(I, J).Value
    aaaZ = Application.WorksheetFunction.CountIf(myArea, aaaX)
    UC = Worksheets(OutSh).Cells(I, Columns.Count).End(xlToLeft).Column + 1
        If aaaZ > 1 Then
            If aaaZ > Application.WorksheetFunction.CountIf(Cells(I, 1).Resize(1, aaaC), aaaX) _
               And Application.WorksheetFunction.CountIf(Sheets(OutSh).Cells(I, 1).Resize(1, J), aaaX) = 0 Then
               Sheets(OutSh).Cells(I, UC).Value = aaaX
            End If
        Else
            Sheets(OutSh).Cells(I, UC).Value = aaaX
'            JJ = JJ + 1
        End If
    DoEvents
    Next J
DoEvents
'If I > 100 Then Exit For
Next I
Sheets(OutSh).Select
Sheets(OutSh).Columns("A:A").Delete Shift:=xlToLeft
'MsgBox (Timer - myTim)
End Sub


Prova e fai sapere
ciao
Flash
Win7 + Office 2010 Ita
"Fotografica" al servizio dell'immagine

Ottime opportunità di lavoro (part-time o full-time) con guadagni immediati. Info in MP
Avatar utente
Flash30005
Moderatore
 
Post: 8460
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: [Excel] rimuovi duplicati in "orizzontale"

Postdi Anthony47 » 10/02/14 13:55

La macro di Flash dovrebbe "collassare" tutti i risultati di una riga in colonne adiacenti, mantenendo lo stesso algoritmo di calcolo della macro precedente.

Per quanto riguarda l' affermazione "ma il file di output "PIPPO" risulta incompleto" dovresti indicare, lavorando sul file che hai condiviso, una riga di esempio in cui ti aspettavi un risultato (quale) e la macro ne ha restituito un altro (quale altro).

Ciao
Anthony
Win7 + Office 2010 Ita; Win 7 + Office 2013 Ita
Xp + Office 2003 Ita
E voi cosa usate? (per istruzioni vedere viewtopic.php?f=26&t=97449)
Avatar utente
Anthony47
Moderatore
 
Post: 13894
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: [Excel] rimuovi duplicati in "orizzontale"

Postdi ninai » 10/02/14 17:33

Ciao a tutti
Assodato che va risolto con VBA, giusto per scrupolo e casomai possa interessare, fornisco proposta con formula che compatta i risultati di ogni riga:
in B1 di un eventuale foglio:
=SE.ERRORE(INDICE(Foglio1!$A1:$APB1;CONFRONTA(0;INDICE(CONTA.SE($A1:A1;Foglio1!$A1:$APB1&""););0));"")
e si trascina in basso ed a destra.
Non è farina mia, l'ho adattata per l'occasione.
Un saluto ad Anthony e Flash
w8 + Office 2010 Ita
ninai
Utente Senior
 
Post: 271
Iscritto il: 12/06/13 05:23
Località: prov. Messina

Re: [Excel] rimuovi duplicati in "orizzontale"

Postdi c_ros » 18/02/14 15:52

La macro di Flash30005 funziona benissimo!
grazie!!!
c_ros
Utente Junior
 
Post: 24
Iscritto il: 06/01/14 19:39

Precedente

Torna a Applicazioni Office Windows


Topic correlati a "[Excel] rimuovi duplicati in "orizzontale"":


Chi c’è in linea

Visitano il forum: patel e 9 ospiti