Conteggio presenze in squadra

[T.Life]

Salve a tutti,
per motivi di organizzazione lavorativa ho in Excel 2010 un foglio che in” A1:A52” sono elencati i nomi di ogni operaio i quali svolgono turni di lavoro a squadre ( A rotazione )di sei persone. Nella colonna “C” tutte le date dei turni svolti da ogni squadra mentre in” E1 j421” tutte le squadre con i nomi che la componeva. Vi chiedo se è possibile ( tramite una macro) sapere, per ogni operaio, quante volte sia stato in squadra con ogni collega.

https://rapidshare.com/files/456827152/ ... 7EA94D85A;

[Anthony47]

Allora...
In Foglio2 (o altro foglio a piacere), copia da A2 verso il basso l' elenco dei nominativi; idem da B1 verso destra (puoi copiare l' elenco creato in colonna A e poi fare Incolla speciale /Valori + Trasponi).
Sono le "Intestazioni" della tabella da compilare.
Copia poi in un Modulo standard del vba (es Modulo1) la seguente macro:

Codice: Seleziona tutto

Sub CrossInd()
'
Dim TopRow As String, ShList As String, ShCross As String
Dim I As Long, LastR As Long, J As Long, K As Long, L As Long, myVARR
Dim myX As String, myY As String, myXVal As Long, myYVal As Long
'
ShList = "Foglio1"      '<< Il foglio con le squadre
TopRow = "F1:K1"        '<< La prima riga dell' elenco squadre
ShCross = "Foglio2"     '<< Il foglio dove sara' preparato il cross-index
'
Sheets(ShCross).Cells(2, 2).Resize(Rows.Count - 2, Columns.Count - 2).ClearContents
LastR = Sheets(ShList).Range(TopRow).Range("A1").End(xlDown).Row
myVARR = Sheets(ShList).Range(TopRow).Resize(LastR).Value
For J = 2 To Sheets(ShCross).Range("B1").End(xlToRight).Column
    For K = 2 To Sheets(ShCross).Range("A2").End(xlDown).Row
        myX = Sheets(ShCross).Cells(1, J)
        myY = Sheets(ShCross).Cells(K, 1)
        For I = 0 To LastR - 1
             myXVal = 0: myYVal = 0
            If myX <> myY Then
                For L = 0 To Range(TopRow).Columns.Count - 1
                    If myVARR(LBound(myVARR, 1) + I, LBound(myVARR, 2) + L) = myX Then myXVal = 1
                    If myVARR(LBound(myVARR, 1) + I, LBound(myVARR, 2) + L) = myY Then myYVal = 1
                Next L
                If (myXVal * myYVal) > 0 Then
                    Sheets(ShCross).Cells(J, K).Value = Sheets(ShCross).Cells(J, K).Value + 1
                End If
            End If
        Next I
    Next K
Next J
End Sub


Personalizza le istruzioni marcate << e poi manda in esecuzione la macro; controlla il risultato su foglio impostato in "ShCross" (attenzione, prima della ri-compilazione l' area dati in "ShCross" sara' azzerata senza nessun preavviso, quindi...)

Ciao

[T.Life]

Si ero quello che cercavo, ma mi restituisce un risultato incompleto.
http://rapidshare.com/files/456827152/P ... forum.xlsx

[Anthony47]

Ho gia' visto quel file.
Mi fai vedere come hai applicato il suggerimento e mi fai un esempio di risultato incompleto?

Ciao

[T.Life]

Si scusa, prima avevo postato il file sbagliato

http://rapidshare.com/files/1554105326/ ... forum.xlsm

[Anthony47]

??
Alludi al fatto che, ad esempio, non c' e' nessun conteggio per Achille /Adam, Achille /Adriano e tanti altri? Allora e' perche' quelle coppie non esistono...
Se alludi ad altro allora dovresti precisare.

Ricorda che nel tuo elenco "molti" nomi sono seguiti da un "spazio": questo potrebbe incasinare se le intestazioni su Foglio2 non sono esattamente uguali ai nomi che compaiono nelle squadre (ma nel caso dei calcoli fatti questo non e' un problema, perche' le intestazioni hanno/non hanno lo spazio come i nomi in tabella "squadre").

Ciao

[T.Life]

Avevi ragione, funziona tutto perfettamente. Sono io che sono un pivello !
Grazie per l'interessamento. Saluti

[T.Life]

Dovrei creare affianco all’area compilata ( dalla macro ) un’altra tabella, ma ogni volta che aggiorno l’area, cancella tutto quello che si trova sul resto del foglio . Come posso fare per contenere la cancellazione solo all’area interessata ?

[Flash30005]

La riga-comando che cancella l'intero range è questa

Codice: Seleziona tutto

Sheets(ShCross).Cells(2, 2).Resize(Rows.Count - 2, Columns.Count - 2).ClearContents

prova a sostituirla e adattarla alla tue esigenze inserndo al suo posto questo codice

Codice: Seleziona tutto

Sheets(ShCross).Range("B2:L1000").ClearContents

(questa ripulisce il range da B2 a L1000)

ciao

[T.Life]

Perfetto Grazie !!!

[Pass96]

Ciao a tutti !!! Mi sono appena iscritto e sono felice di far parte di questo forum
Volevo chiedervi quali sono i valori da cambiare per creare la tabella anziché Foglio2 A2 - B1 esempio in Foglio2 M2 - N1

[Anthony47]

Ciao Pass96, benvenuto nel forum.
Credo che basti modificare le linee marcate **

Codice: Seleziona tutto

Sheets(ShCross).Cells(2, 14).Resize(Rows.Count - 2, Columns.Count - 15).ClearContents     '**
LastR = Sheets(ShList).Range(TopRow).Range("A1").End(xlDown).Row
myVARR = Sheets(ShList).Range(TopRow).Resize(LastR).Value
For J = 14 To Sheets(ShCross).Range("N1").End(xlToRight).Column     '**
    For K = 2 To Sheets(ShCross).Range("M2").End(xlDown).Row     '**
        myX = Sheets(ShCross).Cells(1, J)
        myY = Sheets(ShCross).Cells(K, 13)        '**


Ciao, fai sapere.

[Pass96]

Mi si blocca
http://rapidshare.com/files/2253044235/Cartel1.xlsm

[Flash30005]

Prova la macro così modificata

Codice: Seleziona tutto

Sub CrossInd()
'
Dim TopRow As String, ShList As String, ShCross As String
Dim I As Long, LastR As Long, J As Long, K As Long, L As Long, myVARR
Dim myX As String, myY As String, myXVal As Long, myYVal As Long
'
ShList = "Foglio1"      '<< Il foglio con le squadre
TopRow = "F1:K1"        '<< La prima riga dell' elenco squadre
ShCross = "Foglio2"     '<< Il foglio dove sara' preparato il cross-index
'
 Sheets(ShCross).Range("N2:BU61").ClearContents   '**
LastR = Sheets(ShList).Range(TopRow).Range("A1").End(xlDown).Row
myVARR = Sheets(ShList).Range(TopRow).Resize(LastR).Value
For J = 14 To Sheets(ShCross).Range("N1").End(xlToRight).Column     '**
    For K = 2 To Sheets(ShCross).Range("M2").End(xlDown).Row     '**
        myX = Sheets(ShCross).Cells(1, J)
        myY = Sheets(ShCross).Cells(K, 13)        '**

        For I = 0 To LastR - 1
             myXVal = 0: myYVal = 0
            If myX <> myY Then
                For L = 0 To Worksheets(ShList).Range(TopRow).Columns.Count - 1
                    If myVARR(LBound(myVARR, 1) + I, LBound(myVARR, 2) + L) = myX Then myXVal = 1
                    If myVARR(LBound(myVARR, 1) + I, LBound(myVARR, 2) + L) = myY Then myYVal = 1
                Next L
                If (myXVal * myYVal) > 0 Then
                    Sheets(ShCross).Cells(K, J).Value = Sheets(ShCross).Cells(K, J).Value + 1
                End If
            End If
        Next I
    Next K
Next J
End Sub


ciao

[Anthony47]

Confermo la correzione di Flash sulla linea

Codice: Seleziona tutto

Sheets(ShCross).Cells(K, J).Value = Sheets(ShCross).Cells(K, J).Value + 1

Infatti nella versione originale J e K erano intercambiabili (perche' valori simmetrici); avendo spostato l' asse X sulla N=14 ed essendo invece rimasto l' asse Y sulla riga 2 i valori J e K non sono piu' intercambiabili e la loro posizione deve essere rigidamente associata all' asse di competenza (come ha fatto Flash).

Ciao a tutti.