› Sviluppare funzionalita su Microsoft Office con VBA › Matrice, Vettore e Dictionary.
-
AutoreArticoli
-
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
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?
non credo proprio, oltretutto tu vuoi popolare solo la prima colonna della matrice
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"
Comunque dal mio esempio tu ricavi che non serve un ciclo For per recuperare un'intera colonna da un array. O da un range.
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
Forse se alleghi un file di esempio con i dati ed il risultato desiderato riusciamo a trovare una soluzione più semplice
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.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
Luca vorrei aiutarti come si deve ma ci sono in modo discontinuo. Quanto tempo abbiamo prima dello scadere?
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.
Dove ti sei bloccato? Â
Io ho già steso il codice funzionante e tu?
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
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 🙂
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
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
Capisco... non ti funziona Â
Comunque visto che hai già trovato una soluzione idonea, consideriamo risolta questa.
Però ti lascio la pappardella per eventuale studio 🙂
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
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.
-
AutoreArticoli