You are here:---Rispondi a: [RISOLTO] Controllo doppioni
Rispondi a: [RISOLTO] Controllo doppioni2019-04-28T12:21:19+02:00

Home Forum Domande su Excel VBA e MACRO [RISOLTO] Controllo doppioni Rispondi a: [RISOLTO] Controllo doppioni

sidsid
Moderatore
    Post totali: 718

    Ciao ad entrambi
    Prova questa macro; l’ho testata su entrambi i file e “sembra” funzionare.
    Fai molti test e verifica il corretto funzionamento

    Sub ELIMINA_DOPPIONI()
    
    Dim dict1 As Object, dict2 As Object
    Dim tbl As ListObject
    Dim ws As Worksheet
    Dim j As Long, nk As Long, nRighe As Long, k As Long
    Dim rSeriale As Range, rFY As Range
    Dim firstAddress As String, sCodice As String, sProdotto As String, sUnivoco As String, sListaDoppioni As String
    Dim vArr() As Variant
    
    Set dict1 = CreateObject("Scripting.Dictionary")
    Set dict2 = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    For Each ws In ThisWorkbook.Worksheets
        Select Case ws.Name
            Case "FoglioDaEscludere1", "FoglioDaEscludere2", "TempData"
    
            Case Else
                For Each tbl In ws.ListObjects
                    nRighe = tbl.ListRows.Count
                    If nRighe >= 2 Then
                        For nk = 1 To nRighe - 1
                            If tbl.ListRows(nk).Range.Cells(1, 3) <> vbNullString Then
                                sCodice = tbl.ListRows(nk).Range.Cells(1, 3).Value
                                sProdotto = tbl.ListRows(nk).Range.Cells(1, 4).Value
                                Set rFY = tbl.ListRows(nk).Range.Cells(1, 6).Resize(, 20)
                                With rFY
                                    Set rSeriale = .Find("*", rFY(.Rows.Count, .Columns.Count), xlValues)
                                    If Not rSeriale Is Nothing Then
                                        firstAddress = rSeriale.Address
                                        Do
                                       ' da qui iniziare il dizionario
                                            sUnivoco = sCodice & "-" & sProdotto & "-" & rSeriale.Value
                                            If Not dict1.Exists(sUnivoco) Then
                                                dict1(sUnivoco) = sUnivoco & "#" & ws.Name
                                            Else
                                                dict1(sUnivoco) = dict1(sUnivoco) & "-" & ws.Name
                                                ReDim Preserve vArr(k)
                                                vArr(k) = dict1(sUnivoco)
                                                k = k + 1
                                            End If
                                        Set rSeriale = .FindNext(rSeriale)
                                        Loop While Not rSeriale Is Nothing And rSeriale.Address <> firstAddress
                                    End If
                                End With
                            End If
                        Next nk
                    End If
                Next tbl
        End Select
    Next ws
    
    If k > 0 Then
        For j = UBound(vArr) To LBound(vArr) Step -1
            sUnivoco = Mid(vArr(j), 1, InStr(1, vArr(j), "#", vbTextCompare))
            'secondo dizionario
            If Not dict2.Exists(sUnivoco) Then
                sListaDoppioni = sListaDoppioni & vArr(j) & vbLf
            End If
        Next j
            MsgBox sListaDoppioni, vbInformation, "LISTA DOPPIONI"
    Else
        MsgBox "Nessun doppione trovato", vbInformation, "LISTA DOPPIONI"
    End If
    
    Application.ScreenUpdating = True
    Set dict1 = Nothing
    Set dict2 = Nothing
    Set rFY = Nothing
    Set rSeriale = Nothing
    End Sub

    (anche se ripete i doppioni 2 volte nel MsgBox non mi interessa)

    Dovrei aver risolto anche questo passaggio

    Utilizzando il sito, accetti l'utilizzo dei cookie da parte nostra. maggiori informazioni

    Questo sito utilizza i cookie per fornire la migliore esperienza di navigazione possibile. Continuando a utilizzare questo sito senza modificare le impostazioni dei cookie o cliccando su "Accetta" permetti il loro utilizzo.

    Chiudi