You are here:---Rispondi a: [RISOLTO] Controllo doppioni
Rispondi a: [RISOLTO] Controllo doppioni2019-04-28T14:50:14+02:00

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

sidsid
Moderatore
    Post totali: 718

    Non ancora vengono esclusi dalla ricerca i codici delle liste PIPPO e PLUTO ma va alla grande!

    Questa modifica esclude i range PIPPO e PLUTO dalla ricerca.

    Devi cambiare la fuction in questo modo

    Function EsisteValore(CelleInCuiCercare As Variant, ValoreDaCercare As String) As Boolean
    On Error Resume Next
    EsisteValore = Application.WorksheetFunction.Match(ValoreDaCercare, CelleInCuiCercare, 0)
    On Error GoTo 0
    End Function

    Questa la macro modificata

    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, vRng As Variant, vCod() As Variant, cod As Variant
    
    Set dict1 = CreateObject("Scripting.Dictionary")
    Set dict2 = CreateObject("Scripting.Dictionary")
    
    vRng = Array([Pippo], [Pluto]) 'array che contiene i range da escludere
    
    Application.ScreenUpdating = False
    
    'creo la lista di codici da escludere
    For j = LBound(vRng) To UBound(vRng)
        For Each cod In vRng(j)
            If cod <> vbNullString Then
                ReDim Preserve vCod(k)
                vCod(k) = cod
                k = k + 1
            End If
        Next cod
    Next j
    
    k = 0
    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
                                If Not EsisteValore(vCod, sCodice) Then
                                    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
                            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

    Per quanto riguarda l’intervento di BySalv che saluto, appoggio in pieno il suo approccio.
    In ogni caso mi sono limitato a lavorare su come è stato pensato il file; certo è che potevano pensarlo meglio ;)

    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