Cnfronto multiplo di colonne

[Belvel]

Ciao a tutti

dovrei confontare tra di loro coppie di partite di calcio presenti su 3 gruppi di colonne.
In pratica si tratta di verificare coppie di dati in tutti e tre i gruppi.

Mi spiego:

in A e B ho delle partite di calcio (Gruppo 1)

in D e E ne ho delle altre (Gruppo 2)

in G e H ne ho ancora delle altre ancora (Gruppo 3)

Io ho bisogno di evidenziare in ogni singolo gruppo solo le coppie di partite in comune ai tre gruppi e di riunire in un quarto gruppo (colonne J e K) tutte le partite residue.

Allego esempio:

http://www.filedropper.com/esempio_5

come si può vedere l'unica coppia di partita comune ai 3 gruppi è "juve-inter" per cui in colonna J e K vorrei riunire tutte le coppie di partite presenti nei 3 gruppi eliminando appunto solo "juve-inter" in quanto comune ai 3 gruppi.

Se invece "juve-inter" fosse stata presente solo in uno o due gruppi allora andava mantenuta e messa assieme alle altre nel gruppo 4 (colonne J e K).

Spero si capisca.
Grazie
Belvel

[Anthony47]

L'evidenza si potrebbe probabilmente ottenere con una formattazione condizionale, ma vado subito su una macro:

Codice: Seleziona tutto

Sub Strana()
Dim DI1 As String, DI2 As String, DI3 As String, DOut As String
Dim aAR(1 To 3), myP As Range, myDic As Object, myK As String, I As Long
'
DI1 = "A2"      '<<< La prima area di partite
DI2 = "D2"      '<<< La seconda
DI3 = "G2"      '<<< La terza
DOut = "J2"     '<<< L'area di Out
'
Set aAR(1) = Range(Range(DI1), Range(DI1).Offset(1000, 0).End(xlUp))
Set aAR(2) = Range(Range(DI2), Range(DI2).Offset(1000, 0).End(xlUp))
Set aAR(3) = Range(Range(DI3), Range(DI3).Offset(1000, 0).End(xlUp))
Set myDic = CreateObject("Scripting.Dictionary")
Range(Range(DOut), Range(DOut).Offset(0, 1).End(xlDown)).ClearContents
'Conta le occorrenze:
For I = 1 To 3
    For Each myP In aAR(I)
        myK = myP & myP.Offset(0, 1)
        If myDic.exists(myK) Then
            myDic.Item(myK) = myDic.Item(myK) + 1
        Else
            myDic.Add (myK), 1
        End If
    Next myP
Next I
'Colora o Copia:
For I = 1 To 3
    For Each myP In aAR(I)
        myK = myP & myP.Offset(0, 1)
        If myDic.Item(myK) = 3 Then
            myP.Resize(1, 2).Interior.Color = RGB(255, 255, 0)
        Else
            myP.Resize(1, 2).Interior.ColorIndex = xlNone
            myP.Resize(1, 2).Copy Range(DOut).Offset(1000, 0).End(xlUp).Offset(1, 0)
        End If
    Next myP
Next I
MsgBox ("Completato...")
End Sub


Va messa in un modulo standard del vba; le righe marcate <<< vanno personalizzate come da commento.

Poi all'occorrenza esegui la Sub Strana; da Excel:
-premi Alt-F8, scegli Strana dall'elenco di macro disponibili, premi Esegui

Ho comunque la sensazione di averla fatta piu' complicata di quel che serviva...

Ciao

[Belvel]

Ciao Anthony

non ho parole per ringraziarti, veramente strepitoso.
Funziona alla grande!!!!! :-)
Grazie ancora
Belvel

[Belvel]

Ciao Anthony

ritorno sull'argomento per chiedere una modifica alla macro. In pratica questa macro confronta 3 coppie di colonne ed evidenzia in giallo solo le occorrenze comuni alle 3 colonne. Poi in una quarta colonna copia tutto ciò che non è evidenziato in giallo.

Io vorrei invece fare il contrario: ossia copiare nella quarta colonna solo le occorrenze evidenziate in giallo.
Ho provato a modificare la macro ma non ci sono riuscito :-(

Allego esempio: io vorrei che in colonna J venisse riportato solo ciò che è evidenziato in giallo nei primi tre gruppi di colonne (nell'esempio allegato dovrei e vorrei trovarmi in colonna J tre volte la coppia "Pippo Pluto"):

http://www.filedropper.com/esempio6

Grazie in anticipo
Belvel

[Anthony47]

Nel ciclo finale ("colora o copia") devi spostare l'istruzione .Copy dal blocco Else al blocco If; cioe'

Codice: Seleziona tutto

'Colora o Copia:
For I = 1 To 3
    For Each myP In aAR(I)
        myK = myP & myP.Offset(0, 1)
        If myDic.Item(myK) = 3 Then
            myP.Resize(1, 2).Interior.Color = RGB(255, 255, 0)
            myP.Resize(1, 2).Copy Range(DOut).Offset(1000, 0).End(xlUp).Offset(1, 0)
        Else
            myP.Resize(1, 2).Interior.ColorIndex = xlNone
'            myP.Resize(1, 2).Copy Range(DOut).Offset(1000, 0).End(xlUp).Offset(1, 0)
        End If
    Next myP
Next I

Ciao

[Belvel]

Ciao Anthony, va alla grande :-) Grazie

Solo un'ultima richiesta:

Nelle colonne da confrontare ho dovuto aggiungere il campo "data" e il campo "cat" (in pratica si tratta di incontri di calcio).

Ho poi modificato la macro affinché mi evidenziasse in giallo tutta la riga (includendo quindi data, cat, squadra a e squadra b).

Il problema però è che se lancio la macro, nell'area di OUT, oltre ad avere riportate le partite comuni a tutte e tre le colonne analizzate, ho anche le partite che sono comuni solo in due delle tre colonne. (il mio scopo invece è di avere nell'out solo quelle partite che sono comuni in tutte e tre le colonne analizzate).

Dov'è che ho sbagliato?

Riporto la macro modificata (in pratica ho cambiato le lettere delle colonne da analizzare, la lettera della colonna dell'OUT e infine, nella sezione "colora e copia" la lunghezza da copiare).

Allego anche il file d'esempio.

Come vedi in colonna F:G mi trovo partite che non sono presenti in tutte e tre le colonne esaminate:

http://www.filedropper.com/esempio7

Grazie in anticipo

Codice: Seleziona tutto

Sub Strana()
Dim DI1 As String, DI2 As String, DI3 As String, DOut As String
Dim aAR(1 To 3), myP As Range, myDic As Object, myK As String, I As Long
'
DI1 = "A2"      '<<< La prima area di partite
DI2 = "F2"      '<<< La seconda
DI3 = "K2"      '<<< La terza
DOut = "P2"     '<<< L'area di Out
'
Set aAR(1) = Range(Range(DI1), Range(DI1).Offset(1000, 0).End(xlUp))
Set aAR(2) = Range(Range(DI2), Range(DI2).Offset(1000, 0).End(xlUp))
Set aAR(3) = Range(Range(DI3), Range(DI3).Offset(1000, 0).End(xlUp))
Set myDic = CreateObject("Scripting.Dictionary")
Range(Range(DOut), Range(DOut).Offset(0, 1).End(xlDown)).ClearContents
'Conta le occorrenze:
For I = 1 To 3
    For Each myP In aAR(I)
        myK = myP & myP.Offset(0, 1)
        If myDic.exists(myK) Then
            myDic.Item(myK) = myDic.Item(myK) + 1
        Else
            myDic.Add (myK), 1
        End If
    Next myP
Next I
'Colora o Copia:
For I = 1 To 3
    For Each myP In aAR(I)
        myK = myP & myP.Offset(0, 1)
        If myDic.Item(myK) = 3 Then
            myP.Resize(1, 4).Interior.Color = RGB(255, 255, 0) ' <<< qui ho messo un "4" perché l'area dati da analizzare è aumentata
            myP.Resize(1, 4).Copy Range(DOut).Offset(1000, 0).End(xlUp).Offset(1, 0) ' <<< idem come sopra
        Else
            myP.Resize(1, 4).Interior.ColorIndex = xlNone  ' <<< idem come sopra
            ' myP.Resize(1, 4).Copy Range(DOut).Offset(1000, 0).End(xlUp).Offset(1, 0)  ' <<< qui ho disattivato perché non serve più
        End If
    Next myP
Next I
MsgBox ("Completato...")
End Sub

[Anthony47]

Dov'è che ho sbagliato?

Hai sbagliato a pensare che una cosa fatta per confrontare due colonne ne confronti automaticamente 4
Dovresti pero' chiarire cosa intendi per "partite comuni", cioe' quali sono i campi che determinano se c'e' uguaglianza o meno.

Ciao

[Belvel]

Ciao Anthony, mi spego meglio:

nel file che ho allegato io ho la seguente situazione:

da A a D ho delle partite di calcio (Gruppo 1)

da F a I ne ho delle altre (Gruppo 2)

da K a N ne ho ancora delle altre (Gruppo 3)

Io ho bisogno di evidenziare in ogni singolo gruppo solo le coppie di partite in comune ai tre gruppi e di riunirle in un quarto gruppo (colonne da P a S).

Modificando la macro che tu mi avevi creato sono riuscito quasi nel mio scopo. L'unico problema è che tale macro da me modificata, mi copia nelle colonne da P a S anche quelle partite che, pur evidenziate in giallo, sono presenti solo su due dei tre gruppi di colonne. Io, come detto, ho bisogno di avere da P a S solo quelle coppie di partite che sono in comune nei tre gruppi di colonne che vanno da A fino a N.

Spero aver chiarito
Grazie
Belvel

[Anthony47]

Non hai risposto alla domanda: quali sono le condizioni per cui si puo' dire che un record del gruppo A e' uguale a uno del gruppo B? Cioe' su quali campi bisogna fare il confronto?

[Belvel]

i campi da confrontare sono il campo "DATA", "CAT", "A", "B" del gruppo 1 con il campo "DATA", "CAT", "B", "C" del gruppo 2 e il campo "DATA", "CAT", "D", "E" del gruppo 3.

Se tutti campi sono identici in tutti e 3 i gruppi allora andranno evidenziati in giallo e poi copiati in un quarto gruppo che troviamo nelle colonne da P a S a partire dal campo "DATA".

quindi se ad es io ho questa partita presente in tutti e 3 i gruppi:

DATA: 11 NOV
CAT: ITA
A: Roma
B: Juve

nel gruppo 4 bisogna copiarla tre volte (perché appunto è presente su tutti e tre i gruppi):

[Anthony47]

Il dubbio era se bisognava tenere conto di tutte le 4 colonne o solo delle squadre…

Direi che dovrebbe andare bene questa:

Codice: Seleziona tutto

Sub Strana4()
Dim DI1 As String, DI2 As String, DI3 As String, DOut As String
Dim aAR(1 To 3), myP As Range, myDic As Object, myK As String, I As Long
'
DI1 = "A2"      '<<< La prima area di partite
DI2 = "F2"      '<<< La seconda
DI3 = "K2"      '<<< La terza
DOut = "P2"     '<<< L'area di Out
'
Set aAR(1) = Range(Range(DI1), Range(DI1).Offset(1000, 0).End(xlUp))
Set aAR(2) = Range(Range(DI2), Range(DI2).Offset(1000, 0).End(xlUp))
Set aAR(3) = Range(Range(DI3), Range(DI3).Offset(1000, 0).End(xlUp))
Set myDic = CreateObject("Scripting.Dictionary")
Range(Range(DOut), Range(DOut).Offset(0, 3).End(xlDown)).ClearContents
'Conta le occorrenze:
For I = 1 To 3
    For Each myP In aAR(I)
        myK = myP & myP.Offset(0, 1) & myP.Offset(0, 2) & myP.Offset(0, 3)
        If myDic.exists(myK) Then
            myDic.Item(myK) = myDic.Item(myK) + 1
'            Exit For
        Else
            myDic.Add (myK), 1
        End If
    Next myP
Next I
'Colora o Copia:
For I = 1 To 3
    For Each myP In aAR(I)
        myK = myP & myP.Offset(0, 1) & myP.Offset(0, 2) & myP.Offset(0, 3)
        If myDic.Item(myK) = 3 Then
            myP.Offset(0, 0).Resize(1, 4).Interior.Color = RGB(255, 255, 0)
            myP.Offset(0, 0).Resize(1, 4).Copy Range(DOut).Offset(1000, 0).End(xlUp).Offset(1, 0)
        Else
            myP.Offset(0, 0).Resize(1, 4).Interior.ColorIndex = xlNone
            ' myP.Resize(1, 2).Copy Range(DOut).Offset(1000, 0).End(xlUp).Offset(1, 0)
        End If
    Next myP
Next I
MsgBox ("Completato...")
End Sub

Fai sapere…

[Belvel]

è strepitosa
era quello che cercavo
Grazie infinite Anthony come sempre per la tua gentilezza e disponibilità.
Saluti
Belvel