compilare una tabella : somma gol

[raimea]

ciao
trami macro vorrei compilare una tabella in fgl squadre

la tabella in col X7:AA ( somma gol volte)

vorrei riuscire a prelevare i valori trovati in fgl generale col. N8

inserirli in fgl squadre col X7 in ordine crescente.

poi ad ogni valore di col X :
contare quante volte e' presente in fgl generale e inserirlo in col Y7
contare quante volte stesso valore e' risultato Vincente V in fgl generale e metterlo in col X
contare quante volte stesso valore e' risultato Perdente P in fgl generale e metterlo in col AA

vi allego il file

https://www.dropbox.com/scl/fi/k68x48xv31azwuj5wxyzj/somma_gol.xlsm?dl=0&rlkey=x2yfs4ksiqe8w8s6y45li6lg6


ciao

[Anthony47]

Ad esempio:

Codice: Seleziona tutto

Sub SumGol()
Dim WArr(), wInd As Long, tArr(1 To 4)
Dim GeS As Worksheet, LastN As Long, myMatch
Dim I As Long, J As Long, cSum
'
Set GeS = Sheets("Generale")
LastN = GeS.Cells(Rows.Count, "N").End(xlUp).Row
ReDim WArr(1 To LastN, 1 To 4)
For I = 8 To LastN
    cSum = GeS.Cells(I, "N")
    myMatch = Application.Match(cSum, GeS.Range("N8").Resize(I - 7, 1), False)
    If IsError(myMatch) Then
        wInd = wInd + 1
        WArr(wInd, 1) = cSum
        WArr(wInd, 2) = 1
        If UCase(GeS.Cells(I, "K").Value) = "V" Then
            WArr(wInd, 3) = 1           'V
        Else
            WArr(wInd, 4) = 1           'P
        End If
    Else
        If myMatch > wInd Then wInd = myMatch
        WArr(myMatch, 1) = cSum
        WArr(myMatch, 2) = WArr(myMatch, 2) + 1
        If UCase(GeS.Cells(I, "K").Value) = "V" Then
            WArr(myMatch, 3) = WArr(myMatch, 3) + 1         'V
        Else
            WArr(myMatch, 4) = WArr(myMatch, 4) + 1         'P
        End If
    End If
Next I
'Sheets("Squadre").Range("AC7").Resize(wInd, 4).Value = WArr
'Bubble sort:
For I = 1 To wInd - 1
    For J = I + 1 To wInd
        If WArr(I, 1) > WArr(J, 1) Then
            tArr(4) = WArr(I, 4)
            tArr(3) = WArr(I, 3)
            tArr(2) = WArr(I, 2)
            tArr(1) = WArr(I, 1)
'
            WArr(I, 4) = WArr(J, 4)
            WArr(I, 3) = WArr(J, 3)
            WArr(I, 2) = WArr(J, 2)
            WArr(I, 1) = WArr(J, 1)
'
            WArr(J, 4) = tArr(4)
            WArr(J, 3) = tArr(3)
            WArr(J, 2) = tArr(2)
            WArr(J, 1) = tArr(1)
        End If
    Next J
Next I
Sheets("Squadre").Range("AC7").Resize(wInd, 4).Value = WArr
End Sub


Per consertirti di paragonare l'output a un eventuale altro metodo che usi oggi, essa scrive in colonn AC; dopo le verifiche del caso modifica quel Range("AC7") (in fondo alla macro) in Range("X7")

Ciao

[raimea]

Ciao

la macro sul file allegato e' ok
da il risultato richiesto, scrivendolo da riga 7.

MA
ho fatto un test scrivendo piu dati in col N di fgl generale

la macro riporta in fgl squadre i dati corretti
ma li SCRIVE da riga 8 e non piu da riga 7

ho provato capire perche' ma non l'ho capito.

allego il file con piu dati in col N

https://www.dropbox.com/scl/fi/ccr05on9bi89py00h7r72/somma_gol_2.xlsm?dl=0&rlkey=nnl1vxpf3rby6cjuf3mhpalon

ciao

[Marius44]

Ciao
Il problema sta nell'ordinamento perchè se fai scrivere i dati prima di ordinarli sono alla riga 7

Ciao,
Mario

[raimea]

ciao
ok capito

ma io non sono in grado di modificare / sistemare la macro

ciao

[Anthony47]

No, purtroppo non e' un problema di ordinamento ma proprio di ricerca e catalogazione dei dati.
Questa mi sembra giusta:

Codice: Seleziona tutto

Sub SumGol2()
Dim WArr(), wInd As Long, tArr(1 To 4), mArr
Dim GeS As Worksheet, LastN As Long, myMatch
Dim I As Long, J As Long, cSum
'
Set GeS = Sheets("Generale")
LastN = GeS.Cells(Rows.Count, "N").End(xlUp).Row
ReDim WArr(1 To LastN, 1 To 4)
ReDim mArr(1 To LastN)
For I = 8 To LastN
    mArr = Application.WorksheetFunction.Index(WArr, 0, 1)
    cSum = GeS.Cells(I, "N")
    myMatch = Application.Match(cSum, mArr, False)
    If IsError(myMatch) Then
        wInd = wInd + 1
        WArr(wInd, 1) = cSum
        WArr(wInd, 2) = 1
        If UCase(GeS.Cells(I, "K").Value) = "V" Then
            WArr(wInd, 3) = 1           'V
        Else
            WArr(wInd, 4) = 1           'P
        End If
    Else
        WArr(myMatch, 1) = cSum
        WArr(myMatch, 2) = WArr(myMatch, 2) + 1
        If UCase(GeS.Cells(I, "K").Value) = "V" Then
            WArr(myMatch, 3) = WArr(myMatch, 3) + 1         'V
        Else
            WArr(myMatch, 4) = WArr(myMatch, 4) + 1         'P
        End If
    End If
'Sheets("Squadre").Range("AC7").Resize(wInd, 4).Value = WArr
Next I
'Bubble sort:
For I = 1 To wInd - 1
    For J = I + 1 To wInd
        If WArr(I, 1) > WArr(J, 1) Then
            tArr(4) = WArr(I, 4)
            tArr(3) = WArr(I, 3)
            tArr(2) = WArr(I, 2)
            tArr(1) = WArr(I, 1)
'
            WArr(I, 4) = WArr(J, 4)
            WArr(I, 3) = WArr(J, 3)
            WArr(I, 2) = WArr(J, 2)
            WArr(I, 1) = WArr(J, 1)
'
            WArr(J, 4) = tArr(4)
            WArr(J, 3) = tArr(3)
            WArr(J, 2) = tArr(2)
            WArr(J, 1) = tArr(1)
        End If
    Next J
Next I
Sheets("Squadre").Range("AC7").Resize(wInd, 4).Value = WArr
End Sub


Ri-prova...

[raimea]

ciao

tutto ok

grazie

[Marius44]

Ciao
Tutto è bene quel che finisce bene.
Mi lascia, però, perplesso questa tua dichiarazione:

ma io non sono in grado di modificare / sistemare la macro

Con quasi 1400 interventi qualcosa sicuramente hai imparato e, quindi, potresti tentare un abbozzo.
Tieni presente che non vuole essere una critica. Vale anche per me "lato formule" ma almeno ci provo.

Ciao,
Mario

[raimea]

ciao
sempre nel recuperare un file "corrotto"

dovrei ripristinare la macro >> SumGol (in modulo 2)

Codice: Seleziona tutto

Sub SumGol()

Dim WArr(), wInd As Long, tArr(1 To 4), mArr
Dim GeS As Worksheet, LastN As Long, myMatch
Dim i As Long, j As Long, cSum
'-------------------------
'  gennaio 23
' preleva e ordina la colonna masaniello fgl Tabelle
' da pc-facile antony47
' http://www.pc-facile.com/forum/viewtopic.php?f=26&t=112756&p=662823#p662823
'--------------------------------
Sheets("Tabelle").Select

Application.ScreenUpdating = False  'blocca sfarfallio e non vedo cambiare fgl

INIZIO = Timer
UserForm1.Show vbModeless
DoEvents


Worksheets("Tabelle").Unprotect   ' togli protez

Set GeS = Sheets("Generale")
LastN = GeS.Cells(Rows.Count, "N").End(xlUp).Row

 Range("x7:AA1000").ClearContents ' cnacella elimina dati precedenti
 
ReDim WArr(1 To LastN, 1 To 4)
ReDim mArr(1 To LastN)
For i = 8 To LastN
    mArr = Application.WorksheetFunction.Index(WArr, 0, 1)
    cSum = GeS.Cells(i, "N")
    myMatch = Application.Match(cSum, mArr, False)
    If IsError(myMatch) Then
        wInd = wInd + 1
        WArr(wInd, 1) = cSum
        WArr(wInd, 2) = 1
       
        If UCase(GeS.Cells(i, "K").Value) = "Vinta" Then
       
            WArr(wInd, 3) = 1           'V
        Else
            WArr(wInd, 4) = 1           'P
        End If
    Else
        WArr(myMatch, 1) = cSum
        WArr(myMatch, 2) = WArr(myMatch, 2) + 1
        If UCase(GeS.Cells(i, "K").Value) = "Vinta" Then
            WArr(myMatch, 3) = WArr(myMatch, 3) + 1         'V
        Else
            WArr(myMatch, 4) = WArr(myMatch, 4) + 1         'P
        End If
    End If
   
'Sheets("Tabelle").Range("AC7").Resize(wInd, 4).Value = WArr

Next i

'Bubble sort:
For i = 1 To wInd - 1
    For j = i + 1 To wInd
        If WArr(i, 1) > WArr(j, 1) Then
            tArr(4) = WArr(i, 4)
            tArr(3) = WArr(i, 3)
            tArr(2) = WArr(i, 2)
            tArr(1) = WArr(i, 1)
'
            WArr(i, 4) = WArr(j, 4)
            WArr(i, 3) = WArr(j, 3)
            WArr(i, 2) = WArr(j, 2)
            WArr(i, 1) = WArr(j, 1)
'
            WArr(j, 4) = tArr(4)
            WArr(j, 3) = tArr(3)
            WArr(j, 2) = tArr(2)
            WArr(j, 1) = tArr(1)
        End If
    Next j
Next i

Sheets("Tabelle").Range("X7").Resize(wInd, 4).Value = WArr ' dove mettere i dati

'-----------------------
  '-------coloro riga si no --------------------------------
   
      For Z = 7 To Cells(Rows.Count, "X").End(xlUp).Row  ' 7 1ma riga
   
    Range("X7:AA1000").Interior.ColorIndex = 2  '<<< sfondo bianco
    Range("X7:AA1000").Font.Bold = False
    Next Z
   
    For RR = 7 To Z Step 2
       Range("X" & RR & ":AA" & RR).Interior.ColorIndex = 36
       Range("X" & RR & ":AA" & RR).Font.Bold = True
    Next RR
'---------


   Application.ScreenUpdating = True  ' riattiva sfarfallio
   
Unload UserForm1
fine = Timer
MsgBox ("Tempo impiegato " & Int((fine - INIZIO) / 60) & " min " & (fine - INIZIO) Mod 60 & " Sec")



' -- blocca proteggi foglio----------------------------
   ' ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingColumns:=True, AllowFormattingRows:=True
       
End Sub
 

questa mi dovrebbe prelevare e contare le sigle in fgl generale col N
contare quante volte sono state usate
e riportarlo in fgl tabelle col X7_Y7 ( fin qui funziona)

poi
per ogni sigla trovata dirmi quante volte trova
Vinta / Persa in fgl generale col K8:K ( questo non funziona)
e riportarlo in fgl tabelle col Z _ AB

vi allego il file

https://www.dropbox.com/scl/fi/vw5l6q0fc24aj32k47ojf/masaniello.xlsm?rlkey=absoiq8lzaweabbgz1cykxhky&st=y51fwhef&dl=0

grazie