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,

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

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

Ciao Norma, 

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!

Grazie mille

Dario

Answer 4

Ciao Norman,

molte molte molte grazie!!!! Studio il tutto un attimo e ti faccio sapere!

grazie

Dario

Answer 5

Ciao Dario,

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?

A condizione che io abbia capito bene la tua richiesta, secondo i tuoi obiettivi più ampi e di altre eventuali necessità, ci sono diversi possibili approcci che potrebbero essere adottati, uno di quali è esemplificato dal seguente codice:

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

Option Explicit

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

Public Sub Demo()

'\ Inseririre riferimento alla libreria Microsoft Scripting RunTime

'\ Menu | Strumenti | Riferimenti | Microsoft Scripting RunTime

    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, arr3 As Variant

    Dim arrKeys As Variant, arrItems As Variant

    Dim oDic As Dictionary, oDic2 As Dictionary, oDic3 As Dictionary

    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 = "Risultati"

    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 oDic = New Dictionary

    Set oDic2 = New Dictionary

    oDic.CompareMode = TextCompare

    oDic2.CompareMode = TextCompare

    For i = 1 To UBound(arr, 1)

        aStr = CStr(arr(i, 1))

        If Not oDic.Exists(aStr) Then

            oDic.Add Item:="KO", Key:=aStr

        End If

    Next i

    For j = 1 To UBound(arr2, 1)

        bStr = CStr(arr2(j, 1))

        If Not oDic2.Exists(bStr) Then

            oDic2.Add Item:=vbNullString, Key:=bStr

        End If

    Next j

    Set oDic3 = oDic

    For k = 0 To oDic.Count - 1

        sStr = oDic3.Keys(k)

        If oDic2.Exists(sStr) Then

            oDic3.Item(sStr) = "OK"

        End If

    Next k

    '\ Per dimostrare i risultati

    arrKeys = oDic3.Keys

    arrItems = oDic3.Items

    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(oDic3.Count)

    End With

    With destRng

        With .Rows(0)

            .Value = Array("oDic3 Keys", "oDic3 Items")

            With .Font

                .Size = 14

                .Color = vbRed

                .Bold = True

            End With

        End With

        .Columns(1).Value = Application.Transpose(oDic3.Keys)

        .Columns(2).Value = Application.Transpose(oDic3.Items)

        .EntireColumn.AutoFit

        Call EvidenziareRisultatiOK(destRng)

    End With

XIT:

    Set oDic = Nothing

    Set oDic2 = Nothing

    Set oDic3 = Nothing

End Sub

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

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

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

Nota che si deve inserire un riferimento alla libreria Microsoft Scripting RunTime**:**

Menu | Strumenti | Riferimenti | Microsoft Scripting RunTime

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

                        **http://1drv.ms/1Gro1TA**

===

Regards,

Norman