-
Articoli
-
Per questa sfida (proposta da Patel) si tratta di eliminare i duplicati riga per riga (non nelle colonne) e compattare a sinistra senza lasciare celle intermedie vuote.
Nel file allegato trovate un database di esempio (una semplice anagrafica) in cui i 500 record sono stati trasposti per riga. Occorre costruire la routine (sub o function) che produca il risultato evidenziato.Se qualcuno vuole partecipare ma dispone solo di una versione di Excel inferiore alla 2007 lo faccia sapere in chat o alla mail della redazione. Infatti l'esempio prevede 500 righe di database trasposti per riga, pertanto le 500 colonne risultanti sono compatibili solo con le ultime versioni di Excel.
Le proposte verranno accettate fra cinque giorni da adesso: quindi potrete pubblicare i vostri post da lunedì 29 a partire dalle ore 12. Questa discussione viene chiusa da ora e riaperta al momento giusto.
Eventuali richieste di chiarimento potranno essere fatte in chat o direttamente alla mail della Redazione.
Il vincitore verrà stabilito mediante sondaggio aperto a tutta la comunità: il sondaggio durerà qualche giorno (verrà stabilito al momento della chiusura della sfida). Solo le risposte che arriveranno in questa discussione verranno prese in considerazione.
In caso di parità si terrà conto del criterio cronologico. Ognuno può pubblicare tutte le soluzioni che vuole, ma solo l'ultima postata verrà tenuta in considerazione in caso di parità di voti ottenuti.Il vincitore avrà la soddisfazione di aver partecipato e di aver illustrato qualche tecnica magari nuova o interessante. Inoltre avrà l'onore di proporre la sfida successiva!
Quindi pronti? ...via! cominciate a pensarci, ci rivediamo qui a partire da lunedì prossimo!
Non è tutta farina del mio sacco, ho adattato questo codice alla situazione richiesta
Option Explicit Sub EliminaDoppioni() Dim iListCount As Integer Dim iCtr As Integer Dim a As Integer, f As Integer Application.ScreenUpdating = False a = 3 While a < 11 iListCount = Sheets("foglio1").Cells(a, Columns.Count).End(xlToLeft).Column Sheets("foglio1").Range("b" & a).Select Do Until ActiveCell = "" For iCtr = 1 To iListCount If ActiveCell.Column <> Sheets("foglio1").Cells(a, iCtr).Column Then If ActiveCell.Value = Sheets("foglio1").Cells(a, iCtr).Value Then Sheets("foglio1").Cells(a, iCtr).Delete xlShiftToLeft iCtr = iCtr - 1 End If End If Next iCtr ActiveCell.Offset(0, 1).Select Loop a = a + 1 Wend End Subciao a tutti
Venerdì Acqua quindi mi sono divertito
allego il file con inserite tutte le mie prove
Nel foglio 2 Sub() elimina da Sinistra a destra
Option Explicit Sub No_Doppi_SinDes() Dim i As Long, o As Long, s As Long Dim Vcel As String, StRinga As String Dim S_plit() As String StRinga = "" For i = 3 To 10 For o = 1 To Cells(i, Columns.Count).End(xlToLeft).Column Vcel = Cells(i, o) If Application.CountIf(Range(Cells(i, 1), Cells(i, o)), Vcel) = 1 Then StRinga = StRinga & Vcel & "#" End If Next S_plit = Split(Mid(StRinga, 1, Len(StRinga) - 1), "#") For s = LBound(S_plit) To UBound(S_plit) Cells(i + 10, s + 1) = S_plit(s) Next StRinga = "" Next i End Subnel foglio3 da destra a sinistra e sovrascrive sul DB
Option Explicit Sub No_Duplex_DesSin() Dim i As Long, o As Long, s As Long Dim Vcel As String, StRinga As String Dim S_plit() As String Dim Ncol As Long StRinga = "" Ncol = 1 For i = 3 To 10 For o = Cells(i, Columns.Count).End(xlToLeft).Column To 1 Step -1 Vcel = Cells(i, o) If Application.CountIf(Range(Cells(i, 1), Cells(i, o)), Vcel) = 1 Then StRinga = StRinga & Vcel & "#" End If Next Rows(i).ClearContents S_plit = Split(Mid(StRinga, 1, Len(StRinga) - 1), "#") For s = UBound(S_plit) To LBound(S_plit) Step -1 Cells(i, Ncol) = S_plit(s) Ncol = Ncol + 1 Next StRinga = "" Ncol = 1 Next i End Subnel foglio4 sub() creata col creatore per utilizzare comandi di excel copy trasponi e elimina doppi sempre scrivere sul DB , e apportate modifiche per ciclo For
Sub CreataConCreatoreMacro() ' ' Macro1 Macro ' Dim i As Long For i = 3 To 10 '''Range("A3:SG3").Select Range(Cells(i, "A"), Cells(i, "SG")).Select ''Modifica per ciclo for Application.CutCopyMode = False Selection.Copy Range("A20").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True Application.CutCopyMode = False ActiveSheet.Range("$A$20:$A$520").RemoveDuplicates Columns:=1, Header:= _ xlYes Selection.Copy '''Range("A3").Select Cells(i, "A").Select ''Modifica per ciclo for Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True Next i Range("A1").Select Range("A20:A1000").ClearContents End Subfoglio5 cercato tra gli scaffali del mio pc una formula fatta con funzioni di excel, PS non mi ricordo con chi era stata elaborata, comunque modificata per funzionare in Riga e non in colonna.
Per versione 2003 mancava Se.errore() non supportato in quella versione ma da 2007 e sup
=SE.ERRORE(INDICE($A3:$SG3;PICCOLO(SE(VAL.NUMERO(CONFRONTA(RIF.COLONNA($A3:$SG3);CONFRONTA($A3:$SG3;$A3:$SG3;0);0));CONFRONTA($A3:$SG3;$A3:$SG3;0);""); RIF.COLONNA(A$1)));"")PS da attivare con CTRL+SHIFT+ENTER
ciao
Allegati:
la mia versione
Option Explicit Sub dupremove() Dim LR As Integer, Lc As Long, Sep As String, RigaDest As Integer, c As Long Dim s As String, n As Integer, r As Integer, cell As Range, arr() As String LR = ActiveSheet.UsedRange.Rows.Count Lc = ActiveSheet.UsedRange.Columns.Count Sep = "|" RigaDest = 10 ' zero per sostituire la tabella originale Application.ScreenUpdating = False For r = 3 To LR s = "": n = 0 For Each cell In Range(Cells(r, 1), Cells(r, Lc)) If InStr(s, Sep & cell.Text & Sep) = 0 Then n = n + 1 s = s & cell.Text & Sep End If Next s = Left(s, Len(s) - 1) arr = Split(s, Sep) ' Range(Cells(r, 1), Cells(r, LC)).ClearContents ' necessario con RigaDest = 0 For c = 0 To n - 1 Cells(r + RigaDest, c + 1) = arr(c) Next Next Application.ScreenUpdating = True End SubAllora allego anche la mia versione
che in pratica sfrutta il metodo RemoveDuplicates dei Range e l'opzione Transpose del metodo PasteSpecial. Il codice è tirato un po' per le lunghe ma solo per motivi di estetica e cosmesi del foglio, per avere un risultato finale decente 
Option Explicit Sub readysetgo() Dim i As Integer Application.ScreenUpdating = False Call init Worksheets("Foglio2").Select For i = 3 To 10 ' cicla riga per riga: ' copia e traspone in colonna Rows(i).Copy Range("A14").PasteSpecial Transpose:=True ' rimuove i duplicati Selection.RemoveDuplicates Columns:=Array(1), Header:=xlYes ' ritraspone in riga Range("A14").CurrentRegion.Copy Cells(11 + i, 3).PasteSpecial Transpose:=True Range("A14").CurrentRegion.Clear Next Call finish Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Operazioni concluse", vbInformation End Sub Private Sub init() Dim sh As Worksheet On Error Resume Next Worksheets("Foglio2").Select If Err.Number <> 0 Then Set sh = Worksheets.Add(after:=Worksheets(Worksheets.Count)) sh.Name = "Foglio2" End If On Error GoTo 0 Worksheets("Foglio2").Range("A:SG").Clear With Worksheets("Foglio1") .Range("1:13").Copy Worksheets("Foglio2").Range("A1") End With End Sub Private Sub finish() 'cosmetica finale Range("C14").CurrentRegion.Cut Range("A14") With Range("A14").CurrentRegion .Interior.Color = 14281213 .Borders.LineStyle = xlContinuous End With Range("A1").Select End SubTermine ultimo per presentare le proposte: domenica 5 maggio 2019 ore 20.
C'è di mezzo anche il ponte di mercoledì
Se i partecipanti saranno tanti, probabilmente consentiremo la votazione multipla.
Ciao a Tutti Quattro versioni diverse
la prima sfrutta un dictionary, la seconda usa un rimuovi duplicati, la terza è un brutale elimina celle e sposta a sinistra con loop ricorsivi, la quarta sfutta un vettore e una worksheets.function (countif).
Manca un po' di forma per abbellire il tutto con un clear inziale e un po di colorazione alla fine.....
Ma la sostanza mi sembra esserci.
Aggiunta: Ho inserito il file con i codici. Sono stati modificati per scrivere tutti nelle celle richieste e per colorare il tutto adeguatamente (VF perdonami il copia incolla)
Sub Esercizio5_Luca73_Dic() Dim Dizio01 As Object Dim MioRange As Range Dim CellaInd As Range Dim MioVet As Variant Dim Index Set Dizio01 = CreateObject("Scripting.Dictionary") Dizio01.CompareMode = vbBinaryCompare For Index = 0 To Range("B3", Range("B3").End(xlDown)).Count Set MioRange = Range("B3", Range("B3").End(xlToRight)).Offset(Index, 0) MioRange.Select On Error Resume Next For Each CellaInd In MioRange Dizio01.Add Key:=CellaInd.Value, Item:=CellaInd.Value Next CellaInd Range("B23").Offset(Index, 0).Resize(1, Dizio01.Count) = Dizio01.items Dizio01.RemoveAll Next Set MioRange = Nothing Set Dizio01 = Nothing End Sub Sub Esercizio5_Luca73_RemDup() Dim MioRange As Range Dim NewSheets Dim CellaInd As Range Dim Index Set MioRange = Range(Range("A3").End(xlDown), Range("A3").End(xlToRight)) Set NewSheets = ActiveWorkbook.Sheets.Add MioRange.Copy NewSheets.Range("A1").PasteSpecial Transpose:=True For Each CellaInd In NewSheets.Range("A1", Range("A1").End(xlToRight)) Range(CellaInd, Cells(Rows.Count, CellaInd.Column).End(xlUp)).Select Range(CellaInd, Cells(Rows.Count, CellaInd.Column).End(xlUp)).RemoveDuplicates Columns:=Array(1), Header:=xlYes Next CellaInd NewSheets.Range("A1").Resize(MioRange.Columns.Count, MioRange.Rows.Count).Copy MioRange.Cells(1, 1).Offset(30, 0).PasteSpecial Paste:=xlValue, Transpose:=True NewSheets.Delete Set MioRange = Nothing Set NewSheets = Nothing End Sub Sub Esercizio5_Luca73_RemoveCell() Dim MioRange As Range Dim Riga As Range Dim CellaInd As Range Dim CellaRef As Range Dim Cancellato As Boolean With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual .DisplayAlerts = False End With Range(Range("A3").End(xlDown), Range("A3").End(xlToRight)).Copy Range("A43") Set MioRange = Range(Range("A43").End(xlDown), Range("A43").End(xlToRight)) Range(Range("A3").End(xlDown), Range("A3").End(xlToRight)).Copy Range("A43") 'Set MioRange = Range(Range("A3").End(xlDown), Range("A3").End(xlToRight)).Copy Range("A43") NON FUNZIONA! For Each Riga In MioRange.Rows Set CellaRef = Intersect(Riga, MioRange).Cells(1, 2) Do Cancellato = False For Each CellaInd In Range(Intersect(Riga, MioRange).Cells(1, 2), CellaRef.Offset(0, 0)) If CellaInd = CellaRef.Offset(0, 1) Then CellaRef.Offset(0, 1).Delete Shift:=xlToLeft Cancellato = True Exit For End If Next CellaInd If Not Cancellato Then Set CellaRef = CellaRef.Offset(0, 1) Loop While CellaRef <> "" Next Riga Set MioRange = Nothing With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic .DisplayAlerts = True End With End Sub Sub Esercizio5_Luca73_Vettore() Dim MioRange As Range Dim Riga As Range Dim CellaInd As Range Dim CellaRef As Range Dim Vettore() Dim Indice With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual .DisplayAlerts = False End With Set MioRange = Range(Range("A3").End(xlDown), Range("A3").End(xlToRight)) ReDim Vettore(1 To MioRange.Rows.Count, 1 To 1) For Each Riga In MioRange.Rows Indice = 0 For Each CellaRef In Intersect(Riga, MioRange) If WorksheetFunction.CountIf(Range(Intersect(Riga, MioRange).Cells(1.1), CellaRef), CellaRef.Value) = 1 Then Indice = Indice + 1 If Indice > UBound(Vettore, 2) Then ReDim Preserve Vettore(1 To MioRange.Rows.Count, 1 To Indice) End If Vettore(Riga.Row - MioRange.Cells(1, 1).Row + 1, Indice) = CellaRef.Value End If Next CellaRef Next Riga Range("A25").Resize(MioRange.Rows.Count, UBound(Vettore, 2)) = Vettore With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic .DisplayAlerts = True End With End Sub `Bene. Vedo che vi siete sbizzarriti.
Ho cercato modi diversi per trovare la soluzione. A 6 mi sono fermato.
Tutte le macro postano i risultati nelle righe 14:21
Cliccando successivamente sui pulsanti avrete i risultati (righe da 14 a 21) nonché il tempo impiegato da ciascuna (riga 12 alla destra del relativo pulsante)
La prima macro sfrutta una Collection con chiaveSub EliminaDuplicati_1() 'collection Dim Coll As Collection, tmp1, tmp2 Dim ur As Long, uc As Long, a As Long, i As Long, j As Long Call CancellaRisultato Application.ScreenUpdating = False tmp1 = Timer ur = Cells(Rows.Count, 1).End(xlUp).Row a = 13 For i = 3 To ur uc = Cells(i, Columns.Count).End(xlToLeft).Column Set Coll = New Collection On Error Resume Next For j = 1 To uc Coll.Add Cells(i, j), CStr(Cells(i, j)) Next j On Error GoTo 0 a = a + 1 For j = 1 To Coll.Count Cells(a, j) = Coll(j) Next j Set Coll = Nothing Next i tmp2 = Timer Cells(12, 5) = (tmp2 - tmp1) / 86400 Application.ScreenUpdating = True End SubLa seconda copia con trasposizione i dati, esegue la rimozione dei duplicati, ricopia con trasposizione
Sub EliminaDuplicati_2() 'rimuove duplicati Dim ur As Long, a As Long, i As Long Dim LC As String, elenco As String, tmp1, tmp2 Call CancellaRisultato Application.ScreenUpdating = False tmp1 = Timer Rows("3:10").Copy Range("A24").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True ur = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row a = 13 For i = 1 To 8 LC = Replace(Cells(1, i).Address(False, False), "1", "") elenco = "$" & LC & "$" & 24 & ":" & LC & ur ActiveSheet.Range(elenco).RemoveDuplicates Columns:=1, Header:=xlYes Range(elenco).Copy a = a + 1 Range("A" & a).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True Next i Rows("24:" & ur).Delete tmp2 = Timer Cells(12, 8) = (tmp2 - tmp1) / 86400 Cells(1, 1).Select Application.ScreenUpdating = True End SubLa terza macro anch’essa copia/traspone i dati e poi esegue un filtro per ogni colonna e scrive i risultati trasposti
Sub EliminaDuplicati_3() 'filtro Dim tmp1, tmp2 Call CancellaRisultato Application.ScreenUpdating = False tmp1 = Timer Range("A3:SG10").Copy Range("A25").PasteSpecial Paste:=xlPasteValues, Transpose:=True Range("A25:A550").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("L25"), Unique:=True Range("B25:B550").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("M25"), Unique:=True Range("C25:C550").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("N25"), Unique:=True Range("D25:D550").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("O25"), Unique:=True Range("E25:E550").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("P25"), Unique:=True Range("F25:F550").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("Q25"), Unique:=True Range("G25:G550").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("R25"), Unique:=True Range("H25:H550").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("S25"), Unique:=True Range("L25:S550").Copy Range("A14").PasteSpecial Paste:=xlPasteValues, Transpose:=True Range("A25:S550").ClearContents tmp2 = Timer Cells(12, 11) = (tmp2 - tmp1) / 86400 Cells(1, 1).Select Application.ScreenUpdating = True End SubLa quarta sfrutta un Array particolare (ma è molto più lenta delle altre)
Sub EliminaDuplicati_4() 'con array Dim t() As Variant, r As Range, flag As Boolean, riga Dim i As Long, j As Long, ur As Long, uc As Long, tmp1, tmp2 Call CancellaRisultato Application.ScreenUpdating = False tmp1 = Timer ur = Cells(Rows.Count, 1).End(xlUp).Row For i = 3 To ur ReDim t(0) uc = Cells(i, Columns.Count).End(xlToLeft).Column Set riga = Range(Cells(i, 1), Cells(i, uc)) For Each r In riga flag = True For j = 1 To UBound(t) If t(j) = r Then flag = False Next j If flag Then ReDim Preserve t(UBound(t) + 1) t(UBound(t)) = r End If Next r For j = 1 To UBound(t) Cells(i + 11, j) = t(j) Next j Set riga = Nothing Next i tmp2 = Timer Cells(12, 14) = (tmp2 - tmp1) / 86400 Application.ScreenUpdating = True End SubLa quinta cancella i duplicati lasciando il posto vuoto (è la più lenta di tutte)
Sub EliminaDuplicati_5() 'cancella duplicato e lascia il posto vuoto Dim ur As Long, i As Long, j As Long, k As Long, tmp1, tmp2 Call CancellaRisultato Application.ScreenUpdating = False tmp1 = Timer Rows("3:10").Copy Range("A14").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ur = Cells(14, Columns.Count).End(xlToLeft).Column For i = 14 To 23 For j = 2 To ur - 1 For k = j + 1 To ur If Cells(i, j) <> "" And Cells(i, k) <> "" Then If Cells(i, j) = Cells(i, k) Then Cells(i, k).ClearContents End If Next k Next j Next i tmp2 = Timer Cells(12, 17) = (tmp2 - tmp1) / 86400 Cells(1, 1).Select Application.ScreenUpdating = True End SubLa sesta sfrutta la proprietà .Count di una Dictionary con chiave.
Sub EliminaDuplicati_6() 'dictionary Dim ur As Long, uc As Long, a As Long, i As Long, j As Long, it, y, tmp1, tmp2 Call CancellaRisultato Application.ScreenUpdating = False tmp1 = Timer ur = Cells(Rows.Count, 1).End(xlUp).Row a = 13 For i = 3 To ur uc = Cells(i, Columns.Count).End(xlToLeft).Column ReDim elem(1 To uc) For j = 1 To uc elem(j) = Cells(i, j).Value Next j With CreateObject("scripting.dictionary") For Each it In elem y = .Item(it) Next a = a + 1 For j = 1 To .Count Cells(a, j) = elem(j) Next j End With Next i tmp2 = Timer Cells(12, 20) = (tmp2 - tmp1) / 86400 End SubLa classifica dei tempi (secondo la numerazione suddetta): 3, 2, 6, 1, 4, 5
Non vorrei essere al posto di VF quando si tratterà di "raggruppare" i risultati
Ciao a tutti,
Mario
nonché il tempo impiegato da ciascuna
Ecco perfetto. Alla fine sarà una questione di performances Anche se mi piace molto l'idea dei dizionari (che notoriamente non sono mostri di velocità).
Non vorrei essere al posto di VF
Si accettano collaboratori
Ciao a tutti
Solo per visualizzare il risultato si possono utilizzare un paio di formule:
In A 14 = A3
Da trascinare in basso
In B14 la formula matriciale, premendo CTRL + MAIUSC + INVIO per confermarla:
{=SE.ERRORE(INDICE($A3:$SG3;CONFRONTA(0;CONTA.SE($A14:A14;$A3:$SG3);0));"")}
Da copiare prima a destra e poi in basso
Certo le performance...
x vecchio frac
Prima di postare un esempio con vba volevo utilizzare le formule
Se potete testare i tempi con la formula matriciale es:
{=_xlfn.UNIQUE($A3:$SG3)}
Purtoppo non ho ancora questa formula nel mio foglio Excel 2016!
Giusto per partecipare, due soluzioni.
La prima è simile a quella di vecchio frac, con .RemoveDuplicates:
Sub RemDup_scossa() '--------------------------------------------------------------------------------------- ' Procedure : RemDup_scossa ' Author : scossa ' Date : 27/04/2019 ' Purpose : Sfida numero 5: eliminare duplicati per riga ' https://www.excelvba.it/forumexcel/forums/discussione/sfida-numero-5-eliminare-duplicati-per-riga '--------------------------------------------------------------------------------------- ' Dim rOrigine As Range, rCol As Range Dim rDest As Range, rTemp As Range Dim vDest As Variant Set rOrigine = Foglio1.Range("$A$3:$A$10") Set rDest = rOrigine.Offset(11, 0) rOrigine.Copy rDest Set rOrigine = Foglio1.Range("$B$3:$SG$10") Set rDest = rOrigine.Offset(11, 0) rDest.ClearContents With Application .ScreenUpdating = False vDest = .Transpose(rOrigine) Set rTemp = Foglio1.Range("B37:I536") rTemp = vDest For Each rCol In rTemp.Columns rCol.RemoveDuplicates Columns:=1, Header:=xlNo Next rCol rDest = .Transpose(rTemp) With rDest.CurrentRegion .Interior.Color = 14281213 .Borders.LineStyle = xlContinuous End With .ScreenUpdating = True End With rTemp.Clear Set rOrigine = Nothing Set rDest = Nothing Set rTemp = Nothing End SubL'altra usa una Collection:
Sub RemDup_Coll_scossa() '--------------------------------------------------------------------------------------- ' Procedure : RemDup_Coll_scossa ' Author : scossa ' Date : 27/04/2019 ' Purpose : Sfida numero 5: eliminare duplicati per riga ' https://www.excelvba.it/forumexcel/forums/discussione/sfida-numero-5-eliminare-duplicati-per-riga '--------------------------------------------------------------------------------------- ' Dim oColl As Collection Dim rOrigine As Range, rRow As Range, rDest As Range Dim aOrig As Variant, aEle As Variant, aUnici As Variant Dim j As Long, k As Long Set rOrigine = Foglio1.Range("$A$3:$A$10") Set rDest = rOrigine.Offset(11, 0) rOrigine.Copy rDest Set rOrigine = Foglio1.Range("$B$3:$SG$10") Set rDest = rOrigine.Offset(11, 0) rDest.ClearContents With Application .ScreenUpdating = False On Error Resume Next For Each rRow In rOrigine.Rows k = k + 1 aUnici = rDest.Rows(k).Value2 j = 0 aOrig = .Transpose(rRow) Set oColl = New Collection For Each aEle In aOrig oColl.Add aEle, CStr(aEle) If Err.Number = 0 Then j = j + 1 aUnici(1, j) = aEle End If Err.Clear Next aEle rDest.Rows(k) = aUnici Next rRow With rDest.CurrentRegion .Interior.Color = 14281213 .Borders.LineStyle = xlContinuous End With .ScreenUpdating = True On Error GoTo 0 End With Set oColl = Nothing Set rOrigine = Nothing Set rDest = Nothing Erase aUnici Erase aOrig End SubRagazzi grazie a tutti per la partecipazione! Speriamo che altri siano invogliati a scrivere
Ecco la mia soluzione definitiva con Vba
Option Explicit Sub RemoveAllDupes() Application.ScreenUpdating = False Dim Out As Range, k As Long, Z Dim WB As Workbook, SH As Worksheet Dim Rng As Range Const Foglio As String = "Foglio1" '---- Modifica ---- Const Source As String = "A3" 'Tabella originale Const Mostra As String = "A14" 'Risultato desiderato Set WB = ThisWorkbook Set SH = WB.Sheets(Foglio) Set Rng = SH.Range(Source) Set Out = SH.Range(Mostra) Rng.CurrentRegion.Offset(Out.Row - Rng.Row).ClearContents With CreateObject("scripting.dictionary") For k = 1 To Rng.CurrentRegion.Rows.Count For Each Z In Rng(k).Resize(, Rng.CurrentRegion.Columns.Count) .Item(CStr(Z)) = 1 Next Z Out(k).Resize(, .Count).Value = .Keys .RemoveAll Next k End With Application.ScreenUpdating = True End SubMi son accorto di aver fatto un errore, ho modificato la mia macro ed ho sostituito l'allegato
Buonasera a tutti
lato formule...in B14 da trascinare a destra e poi in basso
=SE.ERRORE(INDICE($B3:$SG3;CONFRONTA(0;INDICE(CONTA.SE($A14:A14;$B3:$SG3&""););0));"")
Ciao a tutti.
Ecco le mie due soluzioni: una con Array e l'altra con una Collection.
Ho provato anche una soluzione che utilizza direttamente i range ma la ometto per decenza (impiega più di 5 secondi!)
Public Sub No_Dup_Array() Dim Colonna As Long, Riga As Long, C1 As Long, C2 As Long, L1 As Long, U1 As Long, L2 As Long, U2 As Long Dim Clc As XlCalculation Dim O(), D(), T() Clc = Application.Calculation Application.Calculation = xlCalculationManual With Sheets("Foglio1") O = .Range("A3").CurrentRegion.Value .Range("A3").CurrentRegion.Offset(11, 0).ClearContents L1 = LBound(O, 1) U1 = UBound(O, 1) L2 = LBound(O, 2) U2 = UBound(O, 2) For Riga = L1 To U1 ReDim T(L2 To U2) C2 = L2 For Colonna = L2 To U2 For C1 = L2 To C2 If O(Riga, Colonna) = T(C1) Then Exit For Next C1 If C1 > C2 Then T(C2) = O(Riga, Colonna) C2 = C2 + 1 End If Next Colonna ReDim Preserve T(L2 To C2) .Range("A3").offset(10 + Riga, 0).Resize(1, C2).Value = T Next Riga End With Application.Calculation = Clc End Sub Public Sub No_Dup_Collection() Dim Origine As Range, rRiga As Range, Cella As Range Dim No_Dup As Collection Dim Colonna As Long, Riga As Long Dim Clc As XlCalculation Application.ScreenUpdating = False Clc = Application.Calculation Application.Calculation = xlCalculationManual With Sheets("Foglio1") Set Origine = .Range("A3").CurrentRegion Origine.CurrentRegion.Offset(11, 0).ClearContents On Error Resume Next For Each rRiga In Origine.Rows Riga = rRiga.Row + 11 Colonna = 1 Set No_Dup = New Collection For Each Cella In rRiga.Cells No_Dup.Add Cella.Value, CStr(Cella.Value) If Err.Number = 0 Then .Cells(Riga, Colonna) = Cella Colonna = Colonna + 1 Else Err.Number = 0 End If Next Cella Set No_Dup = Nothing Next rRiga On Error GoTo 0 Set Origine = Nothing End With Application.ScreenUpdating = True Application.Calculation = Clc End SubStavo preparando la sfida numero 6 quando mi sono accorto della mancanza della numero 5...
Questa discussione era misteriosamente sparita. Grazie Admin per il recupero (anche se parziale è pur sempre qualcosa). Ricordo che il vincitore fu patel 🙂
I log dei voti sono ancora disponibili
Il vincitore fu scossa
Ecco il podio:
[8 voti] Scossa
[7 voti] Mirko
[6 voti] Marius44Ricordo che il vincitore fu patel
Il vincitore fu scossa
Chiedo scusa a scossa... la mia memoria fa cilecca
Login
Registrati
Stai vedendo 4 articoli - dal 1 a 4 (di 4 totali)
Stai vedendo 4 articoli - dal 1 a 4 (di 4 totali)