Vba compilare collection in base ai valori di altre collection

Question

Ciao,

Sto cercando di gestire 3 collection (con scarsi risultati) contemporaneamente:

1. La prima, da cui non posso prescindere, contiene un elenco univoco di nomi caricato da foglio excel (esempio 200 valori)
2. La seconda,da cui posso prescindere, un secondo elenco (pochi elementi) caricato da altro foglio excel (esempio 5 valori).
3. La terza, da cui non posso prescindere, la vorrei popolare in corrispondenza dei valori della prima collection con Ok e KO a seconda che i valori della seconda siano o meno presenti nella prima. 

Ho provato con dei cicli for ma non riesco. Sapete darmi un suggerimento o una strada da provare?

Grazie

Dario

Answer 1

Ciao Dario,

A proposito del confronto di Collection versus Dictionary, forse i commenti in merito di Chip Pearson possano essere di interesse:

'------------->>

The Collection object and the Dictionary object are very useful for storing groups of related data.  All else being equal, I use a Dictionary object rather than a Collection object because you have access (read, write, change) to the Key property associated with an Item in the Dictionary. In a rather poor object design, the Key of an item in a Collection is write-only. You can assign a Key to an Item when you add the Item to the Collection, but you cannot retrieve the Key associated with an Item nor can you determine (directly) whether a key exists in a Collection. Dictionaries are much friendly and open with their keys. Dictionaries are also considerably faster than Collections.

               http://www.cpearson.com/Excel/CollectionsAndDictionaries.htm

'<<-------------

===

Regards,

Norman

Answer 2

Ciao Dario,

Tanto per offrirti una soluzione sfruttando le collection,  in un secondo modulo, incolla il seguente codice:

'=========>>

Option Explicit

'--------->>

Public Sub Demo2()

    Dim WB As Workbook

    Dim SH As Worksheet, newSh As Worksheet

    Dim Rng As Range, Rng2 As Range, Rng3 As Range

    Dim destRng As Range

    Dim arr As Variant, arr2 As Variant, arrOut() As Variant

    Dim oColl As Collection, oColl2 As Collection

    Dim aStr As String, bStr As String, sStr As String

    Dim i As Long, j As Long, k As Long

    Dim iRow As Long, jRow As Long

    Const sNomeNuovoFoglio As String = "Risultati2"

    Const sColonnaElenco1 As String = "A:A"               '<<===== Modifica

    Const sColonnaElenco2 As String = "C:C"                '<<===== Modifica

    Set WB = ThisWorkbook

    Set SH = WB.Sheets("Foglio1")                                 '<<===== Modifica

    With SH

        iRow = LastRow(SH, .Columns(sColonnaElenco1))

        jRow = LastRow(SH, .Columns(sColonnaElenco2))

        Set Rng = .Range(sColonnaElenco1).Cells(2).Resize(iRow - 1)

        Set Rng2 = .Range(sColonnaElenco2).Cells(2).Resize(iRow - 1)

    End With

    arr = Rng.Value

    arr2 = Rng2.Value

    Set oColl = New Collection

    Set oColl2 = New Collection

    For i = 1 To UBound(arr, 1)

        aStr = CStr(arr(i, 1))

        If Not CollectionKeyExists(oColl, aStr) Then

            oColl.Add Item:=aStr, Key:=aStr

        End If

    Next i

    For j = 1 To UBound(arr2, 1)

        bStr = CStr(arr2(j, 1))

        If Not CollectionKeyExists(oColl2, bStr) Then

            oColl2.Add Item:=bStr, Key:=bStr

        End If

    Next j

    ReDim arrOut(1 To oColl.Count, 1 To 2)

    For k = 1 To oColl.Count

        arrOut(k, 1) = oColl(k)

        If CollectionKeyExists(oColl2, oColl(k)) Then

            arrOut(k, 2) = "OK"

        Else

            arrOut(k, 2) = "KO"

        End If

    Next k

    '\ Per dimostrare i risultati

    With WB

        On Error Resume Next

        Set newSh = .Sheets(sNomeNuovoFoglio)

        On Error GoTo XIT

        If Not newSh Is Nothing Then

            newSh.Columns("A:B").ClearContents

        Else

            Set newSh = WB.Sheets.Add(before:=.Sheets(1))

        End If

    End With

    With newSh

        .Name = sNomeNuovoFoglio

        Set destRng = .Range("A2:B2").Resize(oColl.Count, 2)

    End With

    With destRng

        With .Rows(0)

            .Value = Array("Elementi", "Valori")

            With .Font

                .Size = 14

                .Color = vbRed

                .Bold = True

            End With

        End With

        .Value = arrOut

        .EntireColumn.AutoFit

        Call EvidenziareRisultatiOK(destRng)

    End With

XIT:

    Set oColl = Nothing

    Set oColl2 = Nothing

End Sub

'--------->>

Public Function CollectionKeyExists( _

       Coll As Collection, _

       KeyName As String) _

       As Boolean

    Dim var As Variant

    On Error Resume Next

    Err.Clear

    var = Coll(KeyName)

    CollectionKeyExists = (Err.Number = 0)

End Function

'--------->>

Public Sub EvidenziareRisultatiOK(Rng As Range)

    Application.Goto Rng

    With Rng.FormatConditions

        .Delete

        .Add Type:=xlExpression, Formula1:= _

             "=$" _

           & Rng.Cells(1, 2).Address(0, 0) _

           & "=""OK"""

        .Item(.Count).SetFirstPriority

        With .Item(1)

            With .Interior

                .PatternColorIndex = xlAutomatic

                .Color = 65535

                .TintAndShade = 0

            End With

            .StopIfTrue = False

        End With

    End With

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

End Function

'<<=========

Ho aggiornato il mio file di prova al fine di dimostrare entrambe le soluzioni; il codice della soluzione degli oggetti Dictionary si trova nel module di codice Module1 e il codice per la seconda soluzione,  impiegando le Collection, si trova nel modulo di codice Module2. 

Potresti scaricare il mio file di prova aggiornato Dario2_20151005.xlsm a:

                        http://1drv.ms/1Gro1TA

===

Regards,

Norman

Answer 3

Ciao Dario,

grazie mille, tra le due soluzioni mi piace di piu la seconda (anche se entrambe rispondono al mio quesito!), che è quella che userò nel mio codice!

Ti ringrazio del cortese riscontro.

In generale, e soggetto a esigenze particolari, io preferirei invece di utilizzare l'oggetto Dictionary perché: 

• Credo sia intrinsecamente più veloce
• Ha un metodo integrato Exists
• Le sue chiavi sono disponibili, sia in modalità di lettura o scrittura.

Per chiudere questo thread, vorrei chiederti gentilmente di segnare la mia risposta come Risposta. In questo modo, tu aiuterai anche coloro che potessero cercare soluzioni ai problemi simili negli archivi della Community.

===

Regards,

Norman