Sfida del dopo Ferragosto: raggruppa e allinea

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Eccovi una sfida agostiana che a dire il vero mi serve risolvere per un caso reale   

In sintesi, data in ingresso una stringa di testo con delimitatori convenzionali fra diversi elementi, ricavare un testo gradevolmente formattato con ritorni a capo e rientri in modo da separare visivamente i suoi elementi.
La stringa è composta nel modo seguente:
• gruppo¶sottogruppo (testo)• gruppo¶sottogruppo (testo)• gruppo¶sottogruppo (testo)¶ ...
Il risultato da ottenere è questo:

•gruppo1
    sottogruppo1 (testo)
•gruppo2
    sottogruppo2 (testo)

Possono esserci più sottogruppi per ogni gruppo. I sottogruppi uguali  vengono ripetuti se il "testo" è diverso.

•gruppo1
    sottogruppo1 (testoA)
    sottogruppo1 (testoB)
•gruppo2
    sottogruppo1 (testoA)

Può esserci più di un "testo" per ogni sottogruppo; se il "testo" è diverso bisogna raggrupparlo separandolo da altri presenti con virgola (se il "testo" è uguale non deve essere ripetuto):

•gruppo
    sottogruppo (testoA)
    sottogruppo (testoB, testoC)
•gruppo
    sottogruppo (testoA)

La sfida consiste nel risolvere il prodotto di una query di raggruppamento prodotta da Access:

Impresa	                Risorsa	        Mansione
---------------------------------------------------
Topolino e amici Spa	Pippo	        Giardiniere
Topolino e amici Spa	Gastone	        Idraulico
Topolino e amici Spa	zio Paperone	Manovale
Topolino e amici Spa	zio Paperone	Edile
Topolino e amici Spa	Pluto	        Giardiniere
Paperino e nipoti Srl	Paperoga	  Elettricista
Paperino e nipoti Srl	Rockerduck	  Elettricista
Paperino e nipoti Srl	Gastone	        Idraulico

Che ho convertito in questa meravigliosa stringa di testo:

•Topolino e amici Spa¶Pippo(Giardiniere)•Topolino e amici Spa¶Gastone(Idraulico)•Paperino e nipoti Srl¶Paperoga(Elettricista)•Topolino e amici Spa¶zio Paperone(Manovale)•Topolino e amici Spa¶zio Paperone(Edile)•Topolino e amici Spa¶Pluto(Giardiniere)•Paperino e nipoti Srl¶Rockerduck(Elettricista)•Paperino e nipoti Srl¶Gastone(Idraulico)

Il pallino indica l'inizio di un gruppo, il segno di paragrafo indica l'inizio di un sottogruppo, il testo è indicato fra parentesi.
Il risultato finale (fosse da realizzarlo a mano) sarebbe questo:

Topolino e amici Spa
    Pippo (Giardiniere)
    Gastone (Idraulico)
    zio Paperone (Manovale,Edile)
    Pluto (Giardiniere)
Paperino e nipoti Srl
    Paperoga (Elettricista)
    Rockerduck (Elettricista)
    Gastone (Idraulico)

Nota finale: poichè l'argomento riguarda Access, nello specifico, la sfida consiste nell'utilizzare VBA puro senza riferimenti a Excel o Access.

Io ho già realizzato la mia versione che tecnicamente funziona senza problemi, ma ero curioso di vedere altre soluzioni. Magari meno cervellotiche della mia   

[Raffaele53Partecipante Raffaele53 Karma: 23 pts]

Due domande:
1) Può essere che "Topolino e amici Spa" e "Paperino e nipoti Srl" siano mischiati tra loro, oppure sono sempre ordinati come nel post?
2) Sono spazi quelli davanti a (ex Pippo (Giardiniere) oppure basta copiare "Topolino e amici Spa" in colonna A ed " Pippo (Giardiniere)" in colonna B?

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

1) Se intendi il risultato finale, no, non devono e non possono essere mescolati. Il risultato finale e' nell'ultima tabella di riferimento.

2) Sempre avendo presente la tabella finale, sono spazi. Il risultato deve essere inserito in una cella sola, se vogliamo parlare di Excel (ho gia' specificato che non devono essere usati i modelli a oggetto di Excel o Access). Il risultato potrebbe essere visualizzato in una casella di testo. Anche in finestra immediata, al limite.

[Raffaele53Partecipante Raffaele53 Karma: 23 pts]

Nulla, pensavo d'esserci riuscito ma non va bene

 

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Raffaele53 ha scritto:

Mi sono fidato del fatto che fossero in ordine

La stringa in input puo' essere disoprdinata e anzi normalmente lo e' : e' l'output che deve essere riordinato per gruppi  (il livello esterno, l'impresa, e' un gruppo), e possibilmente anche i sottogruppi dovrebbero esserlo (i nominativi cioe' le risorse, ad ognuna delle quali e' associata una o piu' mansioni tra parentesi).

Mo' mi provo la tua proposta. Grazie per il tentativo a priori   

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Raffaele53 ha scritto:

Devo ripensarci...

L'output del tuo codice e':

Topolino e amici Spa
         Pippo(Giardiniere)
         Gastone(Idraulico)
Paperino e nipoti Srl
         Paperoga(Elettricista)
Topolino e amici Spa
         zio Paperone(Manovale)
         zio Paperone(Edile)
         Pluto(Giardiniere)
Paperino e nipoti Srl
         Rockerduck(Elettricista)

Come vedi si tratta adesso di raggruppare le voci di Topolino, tutte sotto Topolino, e quelle di Paperino tutte sotto Paperino. Lo zio Paperone merita una riga soltanto, dove tra parentesi vanno accorpate le due diverse mansioni = "zio Paperone (Manovale,Edile)"
Inoltre a Paperino manca un "Gastone (Idraulico)" che e' anche con Topolino (e' condiviso ma va registrato separatamente).

Non male come inizio (nel modulo devi dichiarare "r" che non e' DIMensionata)   

[scossaPartecipante scossa Karma: 37 pts]

Ciao, 

questo output sarebbe accettabile (cambia solo l'ordinamento)?

Paperino e nipoti Srl
	Gastone (Idraulico)
	Paperoga (Elettricista)
	Rockerduck (Elettricista)
Topolino e amici Spa
	Gastone (Idraulico)
	Pippo (Giardiniere)
	Pluto (Giardiniere)
	zio Paperone (Edile,Manovale)

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

scossa ha scritto:

questo output sarebbe accettabile (cambia solo l'ordinamento)?

Certamente.
L'importante e' rispettare i raggruppamenti e gli accorpamenti (chiaro ormai no? bisogna raggruppare per impresa, per ogni impresa si raggruppano le risorse e per ogni risorsa si raggruppano le mansioni se piu' d'una e' assegnata alla stessa risorsa all'interno della stessa impresa).

[scossaPartecipante scossa Karma: 37 pts]

Bene,

ho buttato giù un codice piuttosto "di getto", che non si appoggia ad Excel ed infatti funziona "paro-paro" anche in un modulo VBA di Access.

L'input è la tua stringa, per l'ordinamento ho usato la solita BubbleSort e l'output è una stringa formattata come sopra riportato.

Const sOrganico As String = "•Topolino e amici Spa¶Pippo(Giardiniere)•Topolino e amici Spa¶Gastone(Idraulico)•Paperino e nipoti Srl¶Paperoga(Elettricista)•Topolino e amici Spa¶zio Paperone(Manovale)•Topolino e amici Spa¶zio Paperone(Edile)•Topolino e amici Spa¶Pluto(Giardiniere)•Paperino e nipoti Srl¶Rockerduck(Elettricista)•Paperino e nipoti Srl¶Gastone(Idraulico)"

Sub Ordina()
  Dim aOrga As Variant, aRisorsa As Variant, aMans As Variant, vEle As Variant
  Dim cRisorsa As Collection
  Dim j As Long
  Dim sRet As String
  
  Set cRisorsa = New Collection
  aOrga = Split(sOrganico, "•")
  aOrga = BubbleSrt(aOrga)
  aRisorsa = aOrga
  ReDim aRisorsa(LBound(aRisorsa) To UBound(aRisorsa), 0 To 2)
  For j = LBound(aOrga) + 1 To UBound(aOrga)
    aRisorsa(j, 0) = Split(aOrga(j), "¶")(0)
    aRisorsa(j, 1) = Split(Split(aOrga(j), "¶")(1), "(")(0)
    aRisorsa(j, 2) = Replace(Split(Split(aOrga(j), "¶")(1), "(")(1), ")", "")
  Next j
  aMans = aRisorsa
  For j = LBound(aRisorsa) To UBound(aRisorsa) - 1
    If aRisorsa(j + 1, 1) = aRisorsa(j, 1) Then
      aMans(j, 2) = aMans(j, 2) & "," & aRisorsa(j + 1, 2)
      aMans(j + 1, 0) = ""
    End If
  Next j
  
  For j = LBound(aMans) + 1 To UBound(aMans)
    If aMans(j, 0) > "" Then
      cRisorsa.Add Array(aMans(j, 0), aMans(j, 1) & " (" & aMans(j, 2) & ")")
    End If
  Next j
  
  For j = 1 To cRisorsa.Count
    vEle = cRisorsa(j)
    If j = 1 Then
      sRet = vEle(0) & vbCrLf
    Else
      If vEle(0) <> cRisorsa(j - 1)(0) Then sRet = sRet & vEle(0) & vbCrLf
    End If
    sRet = sRet & vbTab & vEle(1) & vbCrLf
  Next j
  
  Debug.Print sRet
  Set cRisorsa = Nothing
End Sub

Public Function BubbleSrt(ArrayIn)

  Dim SrtTemp As Variant
  Dim i As Long, j As Long

  For i = LBound(ArrayIn) To UBound(ArrayIn)
    For j = i + 1 To UBound(ArrayIn)
      If ArrayIn(i) > ArrayIn(j) Then
        SrtTemp = ArrayIn(j)
        ArrayIn(j) = ArrayIn(i)
        ArrayIn(i) = SrtTemp
      End If
    Next j
   Next i

  BubbleSrt = ArrayIn

End Function

Come ho detto sopra sicuramente si possono provare strade alternative, magari ci penserò nel week-end.

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

scossa ha scritto:

ho buttato giù un codice piuttosto "di getto", che non si appoggia ad Excel

Il che aderisce perfettamente alla richiesta   

E bubbli una Collection, interessante. L'ordinamento non era strettamente necessario, in realta', pero' sarebbe un risultato apprezzabile.

scossa ha scritto:

Come ho detto sopra sicuramente si possono provare strade alternative

Ora pubblico la mia idea, che e' in pratica un dizionario di dizionari (un dizionario di Imprese in cui la chiave e' l'Impresa e il valore e' un altro dizionario con chiave la Risorsa e valore la/le Mansione/i). Funziona perfettamente ma non riordina i dati (cosa non fondamentale ma sarebbe un quid in piu').

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

La mia idea, una dizionario di dizionari. Sarebbe curiosita' stabilire le performance anche se immagino che con un campione dati cosi' piccolo le differenze non saranno significative (e nella realta' i dati non saranno molti di piu': il report viene costruito al volo, dinamicamente, su un gruppo di una decina di record alla volta, quindi l'esecuzione e' ripetuta n volte ma su un insieme di dati limitato per volta).

Option Explicit

Function grab(ByVal sText As String) As String
Dim s As String
Dim v As Variant
Dim v2 As Variant
Dim v3 As Variant
Dim t As String
Dim impresa As String
Dim risorsa As String
Dim mansione As String
Dim dictI As Object
Dim dictR As Object
Dim w As Variant
    
    On Error GoTo gerr
    
    'debug only
    't = "•Topolino¶Pippo(Giardiniere)•Topolino¶Gastone(Idraulico)•Paperino¶Paperoga(Elettricista)•Topolino¶zio Paperone(Manovale)•Topolino¶zio Paperone(Edile)•Topolino¶Pluto(Giardiniere)•Paperino¶Rockerduck(Elettricista)•Paperino¶Gastone(Idraulico)"
    
    t = sText
    t = Mid(t, 2)
    
    'dict: key, value
    Set dictI = CreateObject("Scripting.Dictionary")
    Set dictR = CreateObject("Scripting.Dictionary")
    
    For Each v In Split(t, "•")
        v2 = Split(v, "¶")
        impresa = v2(0)
        v3 = Split(v2(1), "(")
        risorsa = v3(0)
        mansione = Left(v3(1), Len(v3(1)) - 1)
        
        '- - - - - - - - - - - - - - -
        If dictI.exists(impresa) Then
            Set dictR = CreateObject("Scripting.Dictionary")
            Set dictR = dictI(impresa)
            If dictR.exists(risorsa) Then
                dictR(risorsa) = add_to_list(mansione, dictR(risorsa), ",")
            Else
                Set dictR = dictI(impresa)
                dictR.Add risorsa, mansione
                Set dictI(impresa) = dictR
            End If
        Else
            Set dictR = CreateObject("Scripting.Dictionary")
            dictR.Add risorsa, mansione
            dictI.Add impresa, dictR
        End If
    Next

    s = ""
    For Each v In dictI
        Debug.Print CStr(v)
        s = s & v & "¶"
        For Each w In dictI(v)
            Debug.Print "    " & w & " (" & dictI(v)(w) & ")"
            s = s & w & " (" & dictI(v)(w) & ")" & "¶"
        Next
        s = s & "§"
    Next
    '¶ = stesso gruppo, ritorna a capo e a destra quattro spazi
    '§ = nuovo gruppo, ritorna a capo a inizio riga
    
    s = Replace(s, "¶§", "§")
    If Right(s, 1) = "§" Then s = Left(s, Len(s) - 1)
    Debug.Print vbNewLine & s

    Set dictI = Nothing
    Set dictR = Nothing
    Exit Function
    
gerr:
    Debug.Print "* attenzione errore *"
    Debug.Print Err.Description
    grab = ""
    Set dictI = Nothing
    Set dictR = Nothing
End Function



Public Function add_to_list(ByVal sItem As Variant, ByVal sList As String, Optional ByVal sSeparator As String = " ", Optional ByVal AllowDuplicates As Boolean = False)
'aggiunge un elemento alla lista specificata.
'nella lista gli elementi sono separati da  (default: virgola)
'il parametro opzionale AllowDuplicates permette di aggiungere l'elemento alla lista anche se gia' presente
'(per default l'elemento gia' presente non viene aggiunto alla lista)
'se sItem e' Null non viene aggiunto niente

    If sItem = "" Then
        sList = sList & sSeparator
        If Right$(sList, 1) = sSeparator Then sList = Left$(sList, Len(sList) - 1)
        add_to_list = sList
        Exit Function
    End If
    sItem = Trim(sItem)
    If sList = "" Then
        sList = sItem
        add_to_list = sList
        Exit Function
    End If
    
    If AllowDuplicates Or Not isIn(sItem, sList, sSeparator) Then
        sList = sList & sSeparator & sItem
    End If
        
    If Right$(sList, 1) = sSeparator Then sList = Left$(sList, Len(sList) - 1)
    add_to_list = sList

End Function


Public Function isIn(ByVal sWhat As Variant, ByVal sList As Variant, Optional ByVal delimiter As String = "") As Boolean
'controlla se un valore è in una lista delimitata
Dim v As Variant
Dim i As Integer
Dim s As String
    
    isIn = False
    If sList = "" Then Exit Function
    If delimiter = "" Then
        For i = 1 To Len(sList)
            s = s & Mid$(sList, i, 1) & "|"
        Next
        delimiter = "|"
    Else
        s = sList
    End If
    
    For Each v In Split(s, delimiter)
        If StrComp(Trim(sWhat), Trim(v), vbTextCompare) = 0 Then isIn = True: Exit For
    Next
End Function

La Function principale e' grab, che accetta in input la stringa da testare. Per debug si puo' decommentare la riga di debug iniziale e fare in modo che accetti il testo iniziale della sfida. Le due Function a corredo sono isIn (che verifica se un elemento e' contenuto in una lista) e add_to_list (che aggiunge un elemento a una lista evitando i duplicati). 

[Raffaele53Partecipante Raffaele53 Karma: 23 pts]

In teoria questo funziona con la Tua stringa, non so per altre stringhe.
Corretto l'errore

Option Explicit
Sub Stringa()
Dim txt As String, T1 As String, T2 As String, T3 As String, T4 As String, T5 As String, MsG As String, Tx As String, SgL As String, sTr As String
Dim Num1 As Long, Num2 As Long, X As Long, n1 As Long, n2 As Long, ToT As Long, rR As Long, Z As Long
txt = "•Topolino e amici Spa¶Pippo(Giardiniere)•Topolino e amici Spa¶Gastone(Idraulico)•Paperino e nipoti Srl¶Paperoga(Elettricista)•Topolino e amici Spa¶zio Paperone(Manovale)•Topolino e amici Spa¶zio Paperone(Edile)•Topolino e amici Spa¶Pluto(Giardiniere)•Paperino e nipoti Srl¶Rockerduck(Elettricista)•Paperino e nipoti Srl¶Gastone(Idraulico)"
ToT = Len(txt) - Len(Replace(txt, Chr(149), ""))
txt = Mid(txt, 2, Len(txt)) & Chr(149)
rR = 1
    For X = 1 To ToT
        Num1 = InStr(txt, Chr(182)) - 1
        Num2 = InStr(txt, Chr(149)) - 1
        T1 = Mid(txt, 1, Num1)
        T2 = Mid(txt, Num1 + 2, Num2 - (Num1 + 1))
        T3 = Mid(T2, 1, InStr(T2, "(") - 1)
        T4 = "," & Mid(T2, InStr(T2, "(") + 1, InStr(T2, ")") - 1)
        If InStr(MsG, T1) = 0 Then
            sTr = "@" & rR & "@"
            SgL = SgL & sTr & T1 & ";"
            MsG = MsG & sTr & T1 & ";"
            MsG = MsG & sTr & "         " & T2 & ";"
            rR = rR + 1
            Else
            sTr = Mid(SgL, InStr(SgL, T1) - 3, 3)
            If InStr(MsG, sTr & "         " & T3) = 0 Then
                n1 = InStr(MsG, sTr & " ") - 1
                MsG = Mid(MsG, 1, n1) & sTr & "         " & T2 & Mid(MsG, n1, Len(MsG))
            Else
                n1 = InStr(MsG, sTr & "         " & T3)
                For n2 = n1 + Len(T4) To Len(MsG)
                    If Mid(MsG, n2, 1) = ")" Then Exit For
                Next
                T5 = Mid(MsG, n1, (n2 + 1) - n1)
                T4 = Replace(T5, ")", T4)
                MsG = Mid(MsG, 1, n1 - 1) & T4 & Mid(MsG, n2 + 1, Len(MsG))
            End If
        End If
        Tx = Mid(txt, 1, Num2 + 1)
        txt = Replace(txt, Tx, "")
    Next X
    For X = 1 To rR
        MsG = Replace(MsG, "@" & X & "@", "")
        MsG = Replace(MsG, ";", vbCrLf)
    Next X
MsgBox MsG
End Sub

[scossaPartecipante scossa Karma: 37 pts]

vecchio frac ha scritto:

La Function principale e' grab, che accetta in input la stringa da testare.

ho dato un'occhiata veloce (la studierò meglio nei prossimi giorni) però ho notato che non fai restituire nulla a grab in caso di mancanza di errori (non vedo un'istruzione grab = s): credo sia solo una dimenticanza.

Poi, ma questo lo sai già, non mi piace (e chi se ne frega, penserai)  quell'Exit Function con le istruzioni replicate

.....
    Debug.Print vbNewLine & s

    Set dictI = Nothing
    Set dictR = Nothing
    Exit Function
    
gerr:
    Debug.Print "* attenzione errore *"
    Debug.Print Err.Description
    grab = ""
    Set dictI = Nothing
    Set dictR = Nothing
End Function

preferisco:

...
    Debug.Print vbNewLine & s
    
gerr:
  if Err.Number <> 0 Then
    Debug.Print "* attenzione errore *"
    Debug.Print Err.Description
    grab = ""
  Else
    grab = s
  End If
  Set dictI = Nothing
  Set dictR = Nothing
End Function

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

scossa ha scritto:

credo sia solo una dimenticanza.

E' vero. Come e' vera la frettolosa gestione dell'errore. A parte ringraziarti sia per il codice da te generato che per aver notato questi errori, confermo che nel progetto reale non c'e' l'istruzione "grab = s" che deve restituire il risultato finale: nel mio progetto e' una Sub (come la tua proposta) ma lungo la strada ho pensato che una Function sarebbe meglio. Non c'e' alcuna gestione degli errori (per presunzione... funzionera' sempre tutto benissimo   ). Pero' e' certo che la implementero' nella versione definitiva, possibilmente nella forma da te indicata.

Ho ricreato e adattato al volo il codice per la sfida in forum e chiaramente ho fatto casino.

Nota: il tuo codice e' piu' performante della mia soluzione che coinvolge due dizionari (e' ovvio che sia cosi' perche' tu tratti solo una Collection e array in memoria)

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Raffaele53 ha scritto:

In teoria questo funziona con la Tua stringa, non so per altre stringhe.

Ottimo Raffaele, funziona   

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Questa discussione si puo' considerare chiusa. Grazie come al solito a tutti i partecipanti e contributori!

[Autore]

Articoli