compila 3 colonne in tabella

[raimea]

ciao
premesso che so di aver gia fatto richiesta simile
in questa discussione,

https://www.pc-facile.com/forum/viewtopic.php?f=26&t=111659&start=20

ho provato quindi ad adattare la macro >> ListaTeams
ma il risultato ottenuto non e' quello sperato !

descrivo cosa vorrei ottenere:

dal foglio 4_archivio analizzando la colonna P14:P fino UR
vorrei compilare il fgl >> tabelle

1_in tabelle E7 scrivere il nome di ogni squadra presente in archivio
metterle in ord alfabetico ,
e in col F quante volte la stessa squadra e' stata trovata

2_in tabelle i7 quante volte e' presente il segno descritto in col H

3_in col L7 quante volte e presente la stringa di col K

vi allego il file

https://www.dropbox.com/scl/fi/vr6s1tobm9eud0y0tvrtp/compila-3-dati-in-tabelle.xlsm?rlkey=2b3sqiwfzvqvex34vbbu5fsn4&st=uolog2qh&dl=0

ciao

[Raffaele53]

Da provare

Codice: Seleziona tutto

Option Explicit
Sub Estrai()
Dim sh1 As Worksheet: Set sh1 = Sheets("4_archivio")
Dim sh2 As Worksheet: Set sh2 = Sheets("tabelle")
Dim x As Long, y As Long, uR As Long, Nn As Long, rR As Long
Dim Rg As Object, Msg1 As String, Msg2 As String, Msg3 As String, Msg4 As String
    uR = sh2.Range("E" & Rows.Count).End(xlUp).Row
    If uR > 6 Then sh2.Range("E7:F" & uR) = ""
    sh2.Range("I7:I23") = ""
    sh2.Range("L7:L9") = ""
    uR = sh1.Range("P" & Rows.Count).End(xlUp).Row
    Nn = 7
        For x = 14 To uR
            Msg1 = Mid(sh1.Cells(x, "P"), 1, InStr(sh1.Cells(x, "P"), "/") - 1)
            Msg2 = Mid(sh1.Cells(x, "P"), InStr(sh1.Cells(x, "P"), "/") + 1, 100)
            Msg3 = Trim(Mid(Msg1, 1, InStr(Msg1, "-") - 1))
            Msg4 = Trim(Mid(Msg1, InStr(Msg1, "-") + 1, 100))

            Set Rg = sh2.Range("E6:E1000").Find(Msg3, LookIn:=xlValues, LookAt:=xlWhole)
                If Rg Is Nothing Then
                    sh2.Cells(Nn, "E") = Msg3: sh2.Cells(Nn, "F") = 1: Nn = Nn + 1
                Else
                    rR = Rg.Row
                    sh2.Cells(rR, "F") = sh2.Cells(rR, "F") + 1
                End If
              Set Rg = sh2.Range("E6:E1000").Find(Msg4, LookIn:=xlValues, LookAt:=xlWhole)
                If Rg Is Nothing Then
                    sh2.Cells(Nn, "E") = Msg4: sh2.Cells(Nn, "F") = 1: Nn = Nn + 1
                Else
                    rR = Rg.Row
                    sh2.Cells(rR, "F") = sh2.Cells(rR, "F") + 1
                End If
               
            Msg3 = Trim(Mid(Msg2, 1, InStr(Msg2, "/") - 1))
            Msg4 = Trim(Mid(Msg2, InStr(Msg2, "/") + 1, 100))
             
              Set Rg = sh2.Range("K6:K9").Find(Msg3, LookIn:=xlValues, LookAt:=xlWhole)
                If Rg Is Nothing Then
                Else
                    rR = Rg.Row
                    sh2.Cells(rR, "L") = sh2.Cells(rR, "L") + 1
                End If
              Set Rg = sh2.Range("H6:H23").Find(Msg4, LookIn:=xlValues, LookAt:=xlWhole)
                If Rg Is Nothing Then
                Else
                    rR = Rg.Row
                    sh2.Cells(rR, "I") = sh2.Cells(rR, "I") + 1
                End If
        Next x
    uR = sh2.Range("E" & Rows.Count).End(xlUp).Row
    sh2.Sort.SortFields.Clear
    sh2.Sort.SortFields.Add2 Key:=Range("F7:F" & uR), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    sh2.Sort.SortFields.Add2 Key:=Range("E7:E" & uR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With sh2.Sort
        .SetRange Range("E6:F" & uR)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
MsgBox "Fatto"
Set sh1 = Nothing
Set sh2 = Nothing
Set Rg = Nothing
End Sub

[raimea]

ciao

tutto ok
perfetta

ora per le piccolezze di contorno che mi servono
sono in grado di farle in autonomia.

grazie mille