creare un elenco squadre

[raimea]

ciao
in foglio >> generale, col G
ho le 2 squadre di una partita di calcio.

vorrei creare l elenco alfabetico delle squadre
che sono state gestite.

nel foglio squadre vorrei riportare
1na sola volta , tutte le squadre analizzate di col G.

metterle in ordine alfabetico e a fianco scrivere
quante volte e' presente quella squadra
indifferentemente se in casa o fuori casa

vi allego il file

https://www.dropbox.com/s/e86ttq75lt7x3hm/squadre.rar?dl=0


ciao

[Anthony47]

Probabilmente questa:

Codice: Seleziona tutto

Sub ListaTeams()
Dim gArea As Range, oSh As Worksheet, I As Long
Dim wArr, oArr(), mySplit, J As Long, oInd As Long
Dim tArr
'
Set gArea = ThisWorkbook.Sheets("generale").Range("G:G")            '<<< Colonna Sorgente
Set oSh = ThisWorkbook.Sheets("squadre")                            '<<< Foglio Destinazione
wArr = Application.Intersect(gArea.Parent.UsedRange, gArea).Value
ReDim oArr(1 To 1)
'Estrai le squadre:
For I = 1 To UBound(wArr)
    If wArr(I, 1) <> "" Then
        mySplit = Split(wArr(I, 1), "-", , vbTextCompare)
        If UBound(mySplit) = 1 Then
            For J = 0 To 1
                If IsError(Application.Match(Trim(mySplit(J)), oArr, False)) Then
                    oInd = UBound(oArr)
                    oArr(oInd) = Trim(mySplit(J))
                    ReDim Preserve oArr(1 To oInd + 1)
                End If
            Next J
        End If
    End If
Next I
'ordinamento in Bubble Sort:
For I = 1 To UBound(oArr) - 2
    For J = I + 1 To UBound(oArr) - 1
        If oArr(I) > oArr(J) Then
            tArr = oArr(I)
            oArr(I) = oArr(J)
            oArr(J) = tArr
        End If
    Next J
Next I
'Scrivi elenco squadre:
oSh.Range("A2").Resize(1000, 2).ClearContents
oSh.Range("A2").Resize(oInd, 1) = Application.WorksheetFunction.Transpose(oArr)
'Calcola e scrivi Occorrenze:
For I = 1 To UBound(oArr) - 1
    oInd = 0
    For J = 1 To UBound(wArr)
        If InStr(1, wArr(J, 1) & "  ", oArr(I), vbTextCompare) > 0 Then
            oInd = oInd + 1
        End If
    Next J
    oSh.Range("A2").Cells(I, 2) = oInd
Next I
MsgBox ("Vedi risultati su foglio " & oSh.Name)
End Sub


Ricchi commenti aiutano a seguire la macro.

Come sempre le righe marcate <<< andrebbero adattate al tuo caso; nel foglio di destinazione i risultati vengono scritti da A2:B2 verso il basso, mentre in A1:B1 puoi scrivere l’intestazione che preferisci.

Ciao

[raimea]

ciao
e' tutto ok

ho sistemato le piccole cose come indica , come il scrivere

grazie

[raimea]

ciao
piccolo bug, per casi particolari,

la macro mi conta :
4 volte barcellona
2 volte barcellona B

ma sono 2 squadre diverse
ed entrambe sarebbero da conteggiare 2

e' possibile correggere ?



ciao

[wallace&gromit]

Mi sembra logico che faccia così, perché Barcellona è scritto effettivamente 4 volte. Per evitare dovresti togliere lo spazio dalla seconda, BarcellonaB apparirebbe solo 2 volte così come il semplice Barcellona.

[Anthony47]

Mi sembra logico che faccia così, perché Barcellona è scritto effettivamente 4 volte.

E' vero, "quella macro" non distingue una squadra dall'altra, ma e' sbagliato (cioe' e' troppo elementare) l'algoritmo.
Ho modificato l'ultima parte della macro in questo modo:

Codice: Seleziona tutto

'... (altro)
'Calcola e scrivi Occorrenze:
For I = 1 To UBound(oArr) - 1
    oInd = 0
    For J = 1 To UBound(wArr)
'        If InStr(1, wArr(J, 1) & "  ", oArr(I), vbTextCompare) > 0 Then
'            oInd = oInd + 1
'        End If
        If wArr(J, 1) <> "" Then
            mySplit = Split(wArr(J, 1), "-", , vbTextCompare)
            If UBound(mySplit) = 1 Then
                If oArr(I) = Trim(mySplit(0)) Or oArr(I) = Trim(mySplit(1)) Then
                    oInd = oInd + 1
                End If
            End If
        End If

    Next J
    oSh.Range("A2").Cells(I, 2) = oInd
Next I
MsgBox ("Vedi risultati su foglio " & oSh.Name)
End Sub

Sembra funzionare
Le istruzioni "commentate" sono quelle vecchie; le ho lasciate solo per rendere piu' evidente dove sono intervenuto, ma possono essere eliminate

Ciao

[raimea]

ciao
e' tutto ok

ho sitemato il pezzo di codice
ora distingue barcelona da barcelona B

grazie

[raimea]

ciao
ho provato a modif. la macro sopra
per utilizzarla in altra maniera simile nello stesso file, ma non ci sono riuscito !

in fgl squadre partendo da cella K7

vorrei riportare le nazioni scritte in fgl generale COL E8
e a fianco in col K8 (fgl squade) scrivere quante volte
appare la stessa nazione/ campionato

vi allego il file

https://www.dropbox.com/scl/fi/dux3w1q7p1pa7x7qpmb8y/nazioni.xlsm?dl=0&rlkey=g6lb54j1hh8bp87o2sadqh6hx

ciao

[Anthony47]

Sono pigro, non voglio andare a modificare un codice che non riocrdo che cosa faceva...

Prova con

Codice: Seleziona tutto

Sub RiepTeams()
Dim myMatch
Dim I As Long, iDest As Range, iStart As Range
Dim sOff As Long, dOff As Long
'
Set iDest = Sheets("Squadre").Range("K7")
Set iStart = Sheets("generale").Range("E8")
For I = iStart.Row To iStart.Offset(10000, 0).End(xlUp).Row
    sOff = sOff + 1
    myMatch = Application.Match(iStart.Cells(sOff, 1).Value, iDest.Resize(I, 1), False)
    If IsError(myMatch) Then
        iDest.Offset(dOff, 0).Value = iStart.Cells(sOff, 1).Value
        iDest.Offset(dOff, 1).Value = 1
        dOff = dOff + 1
    Else
        iDest.Cells(myMatch, 2) = iDest.Cells(myMatch, 2) + 1
    End If
Next I
End Sub


Ciao

[raimea]

ciao
tutto ok la macro >> Sub RiepTeams()

grazie

[raimea]

ciao
mi sono accorto che c'e un bug nella 1ma macro >> ListaTeams

quando analizza la col G di fgl generale
separa correttamente le 2 squadre di una partita
ES: Espérance Tunis - ES Sétif

MA importa in fgl squadre anche lo spazio dopo il segno -

questo fa si che l' ordinamento alfabetico successivo nella macro
non da un risultato corretto.

usando sempre lo stesso file allegato
https://www.dropbox.com/scl/fi/dux3w1q7p1pa7x7qpmb8y/nazioni.xlsm?dl=0&rlkey=g6lb54j1hh8bp87o2sadqh6hx

si puo notare che da E7:E49 (fgl Squadre)
ci sono nomi in ordine alfabetico con uno spazio a SX

da E50:E95 ripete l ordinm. alfabetico
ma i nomi non hanno lo spazio a SX

andrebbe tolto lo spazio vuoto a sx prima di fare l 'ordinam. alfabetico.

ciao

[Anthony47]

Per eliminare quel carattere (che non e' uno Spazio ma un suo equivallente usato su pagine web) modifica la riga oArr(oInd) = Trim(mySplit(J)) in

Codice: Seleziona tutto

                    oArr(oInd) = Trim(Replace(mySplit(J), Chr(160), " ", , , vbTextCompare))

Ciao

[raimea]

ciao
tutto ok

x correttezza riporto anche tutta la macro finale :

Codice: Seleziona tutto

Sub ListaTeams()
'------------------------------------------------
' creo l elenco delle squadre su cui ho puntato
' - da pc-facile
' http://www.pc-facile.com/forum/viewtopic.php?f=26&t=111659&p=655809#
' -------------------------------------------------

 Sheets("squadre").Select
 
Dim gArea As Range, oSh As Worksheet, i As Long
Dim wArr, oArr(), mySplit, J As Long, oInd As Long
Dim tArr
'
Set gArea = ThisWorkbook.Sheets("generale").Range("G:G")            '<<< Colonna Sorgente
Set oSh = ThisWorkbook.Sheets("squadre")                            '<<< Foglio Destinazione

wArr = Application.Intersect(gArea.Parent.UsedRange, gArea).Value

ReDim oArr(1 To 1)
'Estrai le squadre:
For i = 1 To UBound(wArr)
    If wArr(i, 1) <> "" Then
        mySplit = Split(wArr(i, 1), "-", , vbTextCompare)
        If UBound(mySplit) = 1 Then
            For J = 0 To 1
                If IsError(Application.Match(Trim(mySplit(J)), oArr, False)) Then
                    oInd = UBound(oArr)
                   
                    oArr(oInd) = Trim(Replace(mySplit(J), Chr(160), " ", , , vbTextCompare))
                   
                    ReDim Preserve oArr(1 To oInd + 1)
                End If
            Next J
        End If
    End If
Next i

'ordinamento in Bubble Sort:
For i = 1 To UBound(oArr) - 2
    For J = i + 1 To UBound(oArr) - 1
        If oArr(i) > oArr(J) Then
            tArr = oArr(i)
            oArr(i) = oArr(J)
            oArr(J) = tArr
        End If
    Next J
Next i

'Scrivi elenco squadre:
oSh.Range("E7").Resize(5000, 2).ClearContents
oSh.Range("E7").Resize(oInd, 1) = Application.WorksheetFunction.Transpose(oArr)
'Calcola e scrivi Occorrenze:
For i = 1 To UBound(oArr) - 1
    oInd = 0
    For J = 1 To UBound(wArr)
        If InStr(1, wArr(J, 1) & "  ", oArr(i), vbTextCompare) > 0 Then
            oInd = oInd + 1
        End If
    Next J
    oSh.Range("E7").Cells(i, 2) = oInd
Next i
 
  '-------coloro riga si no --------------------------------
   
    Range("E7:f500").Interior.ColorIndex = 2  '<<< qui colora una riga
    For RR = 7 To 500 Step 2
        Range("E" & RR & ":f" & RR).Interior.ColorIndex = 36
    Next RR

     
   
   
   
    Columns("A:C").ColumnWidth = 3
    Columns("E:E").ColumnWidth = 35
    Columns("F:F").ColumnWidth = 8
    Columns("D:D").ColumnWidth = 3
   
    ActiveWindow.DisplayGridlines = False


Range("A1").Select

MsgBox (" fatto " & oSh.Name)



End Sub

grazie

[raimea]

ciao
piccolo accorgimento x la macro >>> Sub RiepTeams()

all inizio manca la parte che cancella i dati precedenti

Codice: Seleziona tutto

Range("K7:L500").ClearContents

senza questo i dati escono errati

ciao

[raimea]

ciao
ancora qualcosa di anomalo nella macro >> ListaTeams()

conta 2 volte la stessa squadra
ES Manly United FC
in riga 19 e 45 di fgl generale

in fgl squadre lo scrive 2 volte con il totale corretto
vedi riga 59-60 di fgl squadre

allego il file con la macro gia aggiornata

https://www.dropbox.com/scl/fi/zztzrlumsdlicj5hn0iqw/nazioni.xlsm?dl=0&rlkey=c1f4p0emsfppz9tyxut3ikq2l



ciao

[Anthony47]

Avendo modificato quel che scriviamo come nome squadra dobbiamo analogamente usare lo stesso formato quando si fa la ricerca di esistenza della squadra. Quindi

Codice: Seleziona tutto

'                If IsError(Application.Match(Trim(mySplit(J)), oArr, False)) Then                'ELIMINA
                If IsError(Application.Match(Trim(Replace(mySplit(J), Chr(160), " ", , , vbTextCompare)), oArr, False)) Then     'INSERISCI


[raimea]

ciao
fatto
tutto ok

grazie

[raimea]

ciao
ancora un caso da gestire x la macro >> ListaTeams()

ci sono alcuni casi come quelli nell immagine che non vengono gestiti

Es e' la squadra di riga 40 >> FC Rot-Weiss Koblenz - SG Sonnenhof Großaspach


sara' possibile far rilevare anche questi ?

allego il file
https://www.dropbox.com/scl/fi/zztzrlumsdlicj5hn0iqw/nazioni.xlsm?dl=0&rlkey=c1f4p0emsfppz9tyxut3ikq2l



ciao

[Anthony47]

Il problema e' che il "-" e' usato per separare le squadre ma e' anche talvolta presente all'interno del nome squadra.

Il meglio che posso pensare e' aggiungere questa istruzione in questa posizione:

Codice: Seleziona tutto

        mySplit = Split(wArr(I, 1), "-", , vbTextCompare)
        If UBound(mySplit) > 1 Then mySplit = Split(wArr(I, 1), Chr(160) & "-", , vbTextCompare)
        If UBound(mySplit) = 1 Then

In caso venga rilevato l'uso di "-" all'interno delle squadre provo a usare come separatore la sequenza " - "

Con i dati nel tabellone di oggi ha risolto tutto; non so domani...

[raimea]

certo certo.. capisco
e' tutto legato al trattino -

comunque ho aggiunto la riga al codice
ed e' tutto ok

ancora grazie

ciao