Sviluppare funzionalita su Microsoft Office con VBA Matrice, Vettore e Dictionary.

Login Registrati
Stai vedendo 19 articoli - dal 1 a 19 (di 19 totali)
  • Autore
    Articoli
  • #11439 Score: 0 | Risposta

    Luca73
    Partecipante
      54 pts

      Ciao

      Volevo gentilmente sapere se esiste un metodo rapido per inserire un dictionary in una matrice multidimensionale.

      Devo creare un matrice nX4 dove n sara la dimansione del vettore dictionary.

      Esiste un metodo senza passare da un ciclo for?IO sono riuscito ad arrivare ala seguente macro.

      Ciao Luca

         With Sheets("Discipline")
          arr = .Range("a2", .Cells(.Rows.Count, "h").End(xlUp)).Value
          Set dic = CreateObject("Scripting.Dictionary")
              dic.CompareMode = vbBinaryCompare
              For Counter = 1 To UBound(arr, 1)
                  dic.Item(arr(Counter, 1)) = arr(Counter, 1)
              Next
              ReDim VectorD(1 To dic.Count, 1 To 4)
              Counter = 0
              For Each DisciplinaLav In dic
                  Counter = Counter + 1
                  VectorD(Counter, 1) = DisciplinaLav
              Next
              
      #11442 Score: 0 | Risposta

      vecchio frac
      Senior Moderator
        238 pts

        Eh no questa me la devo studiare con calma, niente risposte affrettate 🙂

        Ma tu vuoi ficcare un oggetto di tipo range dentro il dizionario? e poi sbattere i valori del dizionario di nuovo dentro un array?

        #11443 Score: 0 | Risposta

        patel
        Moderatore
          50 pts

          non credo proprio, oltretutto tu vuoi popolare solo la prima colonna della matrice

          #11455 Score: 0 | Risposta

          vecchio frac
          Senior Moderator
            238 pts

            L'esempio fatto è solo esemplificativo o è caso reale? La mia domanda iniziale tendeva a sapere perchè non ti basta il solo arr, in cui hai già inserito il range che ti serve e di cui recuperi facilmente la prima colonna:

            `Sub test_VF()
            Dim arr As Variant
                
                With Sheets("Discipline")
                    arr = .Range("a2", .Cells(.Rows.Count, "h").End(xlUp)).Value
                    v = Application.Index(arr, , 1)
                    Debug.Print Join(Application.Transpose(v))
                End With
            End Sub
            `

            Edit by VF: scusa, ho dimenticato di dichiarare "v As Variant"

            #11456 Score: 0 | Risposta

            vecchio frac
            Senior Moderator
              238 pts

              Comunque dal mio esempio tu ricavi che non serve un ciclo For per recuperare un'intera colonna da un array. O da un range.

              #11495 Score: 0 | Risposta

              Luca73
              Partecipante
                54 pts

                Ciao

                Allo ra vi spiego bene il mio problema.

                Ho un range/Tabella in cui nella prima colonna ci sono dei Ruoli (disciplina) ripetuti nella seconda/terza colonna ho nome e cognome e nella quarta colonna ho una codifica tipo "TO" o "CC" o "??".

                Volevo ottenere come risultato una matrice che avesse:

                - nella prima colonna della matrice i ruoli (non ripetuti),

                - nella seconda colonna della matrice tutti i nomi (concatenati) con codice TO

                - nella terza colonna della matrice tutti i nomi (concatenati) ) con codice CC

                Ecco perchè avevo usato un dictionary per eliminare i duplicati.

                L'estrazione del pezzo di codice è significativa (è il copia incolla di una vecchio file ce stavo ri-aggiornando)

                Io pertanto avevo pensato:

                1) da un dictionary mi ricavo l'elenco senza ripetizioni poi lo inserisco come prima colonna di una matrice 

                2) ciclo sugli elementi della prima colonna della matrice e mi riempio le altre.

                In generale volevo sapere se è possibile assegnare ad una colonna della matrice in vettore di dimensioni equivalente in via diretta (senza ciclo for)

                Ciao

                Grazie

                #11502 Score: 0 | Risposta

                patel
                Moderatore
                  50 pts

                  Forse se alleghi un file di esempio con i dati ed il risultato desiderato riusciamo a trovare una soluzione più semplice

                  #11504 Score: 0 | Risposta

                  Luca73
                  Partecipante
                    54 pts

                    Eh, Già

                    Patel hai ragione. Lo chiadiamo sempre a tutti e poi mi dimentico io....  

                    In allegato un file con due Fogli nel foglio Discipline la tabella di partenza. 

                    Nell'altro foglio una immagine della matrice di cui ho bisogno nel mio Codice.

                    Ciao

                    Luca

                    Allegati:
                    You must be logged in to view attached files.
                    #11513 Score: 0 | Risposta

                    patel
                    Moderatore
                      50 pts

                      io eliminerei i duplicati senza ricorrere a dictionary così

                      Sub eliminaduplicaticolonna1()
                      Dim r As Range
                      LR = Cells(Cells.Rows.Count, "A").End(xlUp).Row
                      Set r = Range("A2:H" & LR)
                      r.RemoveDuplicates Columns:=Array(1), Header:=xlNo
                      End Sub
                      #11557 Score: 0 | Risposta

                      vecchio frac
                      Senior Moderator
                        238 pts

                        Luca vorrei aiutarti come si deve ma ci sono in modo discontinuo. Quanto tempo abbiamo prima dello scadere?

                        #11563 Score: 0 | Risposta

                        vecchio frac
                        Senior Moderator
                          238 pts

                          In effetti dopo aver visto il file mi è tutto più chiaro.

                          Allora io ti propongo di usare la mia solita tecnica della lettura del database Excel via ADO, raggruppando per Dept, ottieni diversi Dept Description per ognuno dei quali ricavi il campo To/CC che manipoli opportunamente. SQL ti verrà in aiuto facilmente così da evitare di smazzarti con dizionari e cicli. Un bel recordset opportunamente filtrato e hai i dati già raggruppati.

                          #11629 Score: 0 | Risposta

                          vecchio frac
                          Senior Moderator
                            238 pts

                            Dove ti sei bloccato?   

                            Io ho già steso il codice funzionante e tu?

                            #11698 Score: 0 | Risposta

                            Luca73
                            Partecipante
                              54 pts

                              Ciao 

                              Eccomi, il Week end tendenzialmente non apro il computer....

                              Ecco quanto avevo scritto come ultima prova. Funzionare funziona.

                              Forse si può fare di meglio.

                              @ VF

                              1) dove posso trovare un po' di materiale sulla lettura del database Excel via ADO?

                               1) con SQL come faccio a unire dati partendo da diverse celle e mettertli tutti assieme?ti verrà in aiuto facilmente così da evitare di smazzarti con dizionari e cicli. Un bel recordset opportunamente filtrato e hai i dati già raggruppati.

                              Qui sotto il mio risultato. Ho eliminato in quanto non pertinente all'analisi la parte in cui la matrice viene data in pasto ad una altro pezzo di codice che la trasforma in una tabella in HTML per poi allegarla ad una mail.

                              Function TabellaFinale2()
                              
                              Dim IndiceDisc
                              Dim arr As Variant
                              Dim Counter As Long
                              Dim dic_Disc As Object
                              Dim dic_DiscTO As Object
                              Dim dic_DiscCC As Object
                              Dim VectorD As Variant
                              Dim primo As Boolean
                              Dim DisciplinaLav
                              Dim Index
                              
                              [...]
                                  With Sheets("Discipline")
                                      arr = .Range("a2", .Cells(.Rows.Count, "h").End(xlUp)).Value
                                  End With
                                  Set dic_Disc = CreateObject("Scripting.Dictionary")
                                  Set dic_DiscCC = CreateObject("Scripting.Dictionary")
                                  Set dic_DiscTO = CreateObject("Scripting.Dictionary")
                                      dic_Disc.CompareMode = vbBinaryCompare
                                      dic_DiscCC.CompareMode = vbBinaryCompare
                                      dic_DiscTO.CompareMode = vbBinaryCompare
                                      For Counter = 1 To UBound(arr, 1)
                                          dic_Disc.Item(arr(Counter, 1)) = arr(Counter, 2)
                                          If Not (dic_DiscCC.Exists(arr(Counter, 1))) Then
                                              dic_DiscCC.Item(arr(Counter, 1)) = ""
                                          End If
                                          If Not (dic_DiscTO.Exists(arr(Counter, 1))) Then
                                              dic_DiscTO.Item(arr(Counter, 1)) = ""
                                          End If
                                          If arr(Counter, 8) = "TO" Then
                                                  dic_DiscTO.Item(arr(Counter, 1)) = dic_DiscTO.Item(arr(Counter, 1)) & arr(Counter, 4) & " " & arr(Counter, 5) & " <BR> "
                                          ElseIf arr(Counter, 8) = "CC" Then
                                                  dic_DiscCC.Item(arr(Counter, 1)) = dic_DiscCC.Item(arr(Counter, 1)) & arr(Counter, 4) & " " & arr(Counter, 5) & " <BR> "
                                          End If
                                      Next
                                      Dim pippo
                                      Counter = 0
                                      ReDim VectorD(1 To dic_Disc.Count + 1, 1 To 4)
                                      For Each DisciplinaLav In dic_Disc
                                          Counter = Counter + 1
                                          VectorD(Counter, 1) = DisciplinaLav
                                          VectorD(Counter, 2) = dic_Disc(dic_Disc)
                                          VectorD(Counter, 3) = dic_DiscTO(dic_Disc)
                                          VectorD(Counter, 4) = dic_DiscCC(dic_Disc)
                                      Next
                              
                              Set dic_Disc = Nothing
                              Set dic_DiscCC = Nothing
                              Set dic_DiscTO = Nothing
                              
                              [...]
                              
                              End Function
                              #11699 Score: 0 | Risposta

                              vecchio frac
                              Senior Moderator
                                238 pts

                                Dunque, partendo dal basso, consiglio di spezzare il codice in due parti, il primo pezzo che si occupa di creare una nuova tabella raggruppando opportunamente per TO/CC/Unknown gli indirizzi dei destinatari, e il secondo pezzo (una function, una sub) che si occupa di creare il codice html. Così hai una separazione logica tra le funzioni.

                                Poi, esaminando la tua produzione, capisco la fatica concettuale di non perdere il filo del discorso tra indici, dizionari e vettori. Un bell'impegno. Un dizionario separato per ogni gruppo, un array a due dimensioni (perchè rappresenta un range) di cui recuperare gli indici giusti, un nuovo ciclo per reinserire in un nuovo vettore i dati desiderati. Scusami ma io faccio fatica a rileggere questo codice e a ricostruirlo. Probabilmente la mia proposta mi sembra più fluida, ma ognuno ha il proprio stile e utilizza soprattutto il proprio bagaglio di nozioni.

                                Unire dati provenienti da diverse celle con SQL, direttamente con il dialetto SQL di Jet non è possibile (altri dialetti hanno funzioni apposta per raggruppare o concatenare gruppi), ma si raggiunge ugualmente il risultato con un metodo del recordset che si chiama GetString. 

                                Materiale su Excel e ADO ce n'è a tonnellate (è una tecnica molto vecchia ma funziona ancora). Io stesso sto preparando un breve articolo per il nostro blog, più un appunto di viaggio e una guida veloce che un manuale tecnico, ma sarà sufficiente per la maggior parte dei casi, come questo che è in fondo alla portata di tutti.

                                Ma basta parlare, allego il codice 🙂

                                #11700 Score: 0 | Risposta

                                vecchio frac
                                Senior Moderator
                                  238 pts

                                  Ho perso un attimo a commentare il codice.

                                  HTH

                                  Option Explicit
                                   
                                  Sub group_data()
                                  Dim objConnection As Object
                                  Dim rs As Object, rs2 As Object
                                  Dim s As String, SQL As String
                                  Dim j As Long
                                  Dim ur As Long
                                  Dim i As Integer
                                  Dim m As String, n As String
                                  
                                  Const adOpenStatic = 3
                                  Const adLockOptimistic = 3
                                  Const adCmdText = &H1
                                  Const adClipString = 2
                                  
                                      i = 0
                                      On Error Resume Next
                                      i = Sheets("results").Index
                                      On Error GoTo 0
                                      
                                      'aggiunge il foglio "results"
                                      If i = 0 Then
                                          Sheets.Add after:=Sheets(Sheets.Count)
                                          ActiveSheet.Name = "results"
                                      End If
                                      
                                      'prepara il foglio results a rcaccogliere i dati
                                      'e descrive le intestazioni
                                      With Sheets("results")
                                          .Range("A1").CurrentRegion.ClearContents
                                          .Range("A1:E1") = Split("Dept,Dept Description,TO,CC,??", ",")
                                      End With
                                  
                                      'salva una copia temporanea del file per la lettura dei dati
                                      'la copia sarà eliminata alla fine
                                      s = ThisWorkbook.Path & "\temporary.xlsx"
                                      ThisWorkbook.SaveCopyAs s
                                      
                                      'crea gli oggetti connecitone e recordset necessari
                                      Set objConnection = CreateObject("ADODB.Connection")
                                      Set rs = CreateObject("ADODB.Recordset")
                                      Set rs2 = CreateObject("ADODB.Recordset")
                                      
                                      objConnection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                                          "Data Source=" & s & ";Extended Properties=""Excel 12.0 Macro;HDR=Yes;"";"
                                      
                                      'ultima riga della tabella
                                      ur = Sheets("Discipline").Range("A1").CurrentRegion.Rows.Count
                                      
                                      'prepara la query che recupera i "dept" in modo univoco
                                      SQL = Replace(SQL, "%1", "[Discipline$A1:H" & ur & "]")
                                      rs.Open "SELECT Dept, [Dept description] FROM [Discipline$A1:H" & ur & "] GROUP BY Dept, [Dept description]", objConnection, adOpenStatic, adLockOptimistic, adCmdText
                                  
                                      Sheets("results").Select
                                      j = 2
                                      
                                      'prepara la query che per ogni dept raggruppa per destinatario (to/cc) e raccoglie i nominativi
                                      'ci sono i segnaposto (%numero) che verranno rimpiazzati dai dati durante l'esecuzione
                                      SQL = "Select Surname & ' ' & dictionary From [Discipline$A1:H" & ur & "] As T1 Where [to/cc]='%2' And T1.Dept = '%3'"
                                      
                                      'cerco di ignorare gli errori: con questo sistema, da usare con cautela!,
                                      'evito di scrivere codice che verifica se getString tenta di leggere un record nullo
                                      On Error Resume Next
                                      
                                      Do Until rs.EOF
                                          Cells(j, "A") = rs("Dept")
                                          Cells(j, "B") = rs("Dept description")
                                          
                                          'per ogni tipo destinatario (to/cc/sconosciuto) recupera cognome e nome, separandoli da punto e virgola se multipli
                                          For i = 1 To 3
                                              'imposto il tipo di destinatario (ciclo tra to, cc e ??)
                                              m = Replace(SQL, "%2", Choose(i, "TO", "CC", "??"))
                                              m = Replace(m, "%3", rs("dept"))
                                              'raccolgo in un recordset dedicato la query precedente
                                              Set rs2 = objConnection.Execute(m)
                                              'GetString è il cuore del join tra dati di recordset diversi
                                              n = rs2.GetString(adClipString, , , "; ")
                                              If Right(n, 2) = "; " Then n = Left(n, Len(n) - 2)
                                              Cells(j, i + 2) = n
                                              n = ""
                                          Next
                                  
                                          'riga successiva
                                          j = j + 1
                                          'record successivo
                                          rs.movenext
                                      Loop
                                      
                                      'ripristino la gestione degli errori
                                      On Error GoTo 0
                                          
                                      'chiude i recordset e le connessioni
                                      rs.Close
                                      rs2.Close
                                      objConnection.Close
                                      'elimino il file temporaneo
                                      Kill s
                                      'adatto le colonne alla loro larghezza
                                      Range("A:E").Columns.AutoFit
                                  End Sub
                                  
                                  #11701 Score: 0 | Risposta

                                  Luca73
                                  Partecipante
                                    54 pts

                                    Ciao VF

                                    Il tempo è tiranno e partendo da vecchi file a volte per non stravolgere altri pezzi di lavoro a volte i risultati non sono i migliori.

                                     

                                    Ciao

                                    Luca

                                    #11702 Score: 0 | Risposta

                                    vecchio frac
                                    Senior Moderator
                                      238 pts

                                      Capisco... non ti funziona   

                                      Comunque visto che hai già trovato una soluzione idonea, consideriamo risolta questa.

                                      Però ti lascio la pappardella per eventuale studio 🙂

                                      #11703 Score: 0 | Risposta

                                      Luca73
                                      Partecipante
                                        54 pts

                                        Ciao VF 

                                        no, non volevo dire che non funziona. Volevo solo dire che se avessi avuto tempo e maggiore libertà (non rimanendo bloccato da pezzi di codice pre-esistente, farei tutto diversamente.)

                                        Al momento la tua soluzione la sto studiando. 

                                        Secondo me per la particolare applicazione è più lunga e complessa ma l'utilizzo di ADO e SQL mi "attizza". Nei tempi passati avevo letto un libro su SQL, dovrò riprenderlo. Invece riguardo ad ADO ha qualche sito che tu usi di più in quanto ben fatto.

                                        Il problema di avere un tonnellata di material è la difficoltà per chi non conosce di muoversi al suo interno.

                                        Pertanto se hai dei suggerimenti o dei documenti da cui partire mi saresti di aiuto.

                                        Ciao. Grazie mille Luca

                                        #11705 Score: 0 | Risposta

                                        vecchio frac
                                        Senior Moderator
                                          238 pts

                                          Dunque in realtà io non ho grandi suggerimenti da darti, mi barcameno con la guida in linea (che coi nuovi Office rimanda a quella online ma è la stessa cosa) e leggo spesso le discussioni su stackoverflow (chi non l'ha fatto?!).

                                          Una base fondamentale anche se datata (ma ripeto, la tecnica è consolidata) è quella che trovi in pole position digitando "excel ado " in Google, che ti rimanda all'articolo Microsoft intitolato: "Utilizzo di ADO per leggere e scrivere dati in cartelle di lavoro di Excel illustrato in ExcelADO".

                                          ExcelADO è un file di esempio (è un eseguibile che contiene un progetto VB importabile).

                                          Naturalmente cambiano le stringhe di connessione perchè l'articolo è del 2000 e allora non c'erano i nuovi Excel ma a questo si rimedia facilmente cercando il sito connectionstrings.com, che è una miniera di informazioni sulla connessione dei diversi modelli, ed è aggiornato.

                                        Login Registrati
                                        Stai vedendo 19 articoli - dal 1 a 19 (di 19 totali)
                                        Rispondi a: Matrice, Vettore e Dictionary.
                                        Gli allegati sono permessi solo ad utenti REGISTRATI
                                        Le tue informazioni: