Collection con valori univoci e ordinati
draleo
voci (stringhe) NON ORDINATE contenente molti voci duplicate
Dovendo caricare una listBox con tali dati UNIVOCI e ORDINATI
alfabeticamente, ho trovato, in un vecchio thread , un listato che compie
magnificamente il tutto
Il problema è che non riesco a capire il funzionamento della parte del
listato che riguarda l’ordinamento delle voci
Qualcuno può aiutarmi a capirci qualcosa, commentando le righe interessate?
Quello sotto è il listato
Sotto ancora riporto la parte della quale gradirei il commento
Grazie a chi vorrà illuminare un somaro del VBA
Draleo
'In un modulo standard, prima di qualsiasi codice
Public arr As Variant
Option Compare Text 'per non distinguere maiuscole e minuscole
Sub CreaElencoUnivoco()
Dim WB As Workbook
Dim SH As Worksheet
Dim Rng As Range, rCell As Range
Dim LRow As Long
Dim NoDupes As New Collection
Dim i As Long, j As Long
Dim Swap1 As Variant, Swap2 As Variant
Dim myItem As Variant
Set WB = ActiveWorkbook
Set SH = WB.Sheets("statis accert")
LRow = Cells(Rows.count, "G").End(xlUp).Row
Set Rng = SH.Range("G13:G" & LRow)
arr = Rng.Resize(, 3)
On Error Resume Next
For Each rCell In Rng.Cells
With rCell
If Not IsEmpty(.Value) Then
NoDupes.Add .Value, CStr(.Value)
End If
End With
Next rCell
On Error GoTo 0
'le righe seguenti per ordinare i dati
For i = 1 To NoDupes.count - 1
For j = i + 1 To NoDupes.count
If NoDupes(i) > NoDupes(j) Then
Swap1 = NoDupes(i)
Swap2 = NoDupes(j)
NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1
End If
Next j
Next i
For Each myItem In NoDupes
UserForm2.ListBox2.AddItem myItem
Next myItem
End Sub
Questa è la parte di cui non capisco nulla e che credo effettui l’ordinamento
For i = 1 To NoDupes.count - 1
For j = i + 1 To NoDupes.count
If NoDupes(i) > NoDupes(j) Then
Swap1 = NoDupes(i)
Swap2 = NoDupes(j)
NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1
End If
Next j
Next i
Bruno Campanini
news:5374CABA-6C58-45D4...@microsoft.com...
> Nel foglio “statis accertamenti” ,dalla cella G13 in giù, ho un Elenco di
> voci (stringhe) NON ORDINATE contenente molti voci duplicate
[...]
> Questa è la parte di cui non capisco nulla e che credo effettui l’ordinamento
>
> For i = 1 To NoDupes.count - 1
> For j = i + 1 To NoDupes.count
> If NoDupes(i) > NoDupes(j) Then
> Swap1 = NoDupes(i)
> Swap2 = NoDupes(j)
> NoDupes.Add Swap1, before:=j
> NoDupes.Add Swap2, before:=i
> NoDupes.Remove i + 1
> NoDupes.Remove j + 1
> End If
> Next j
> Next i
Si tratta di un bubble-sort (la forma più intuitiva e meno efficiente
di sorting) effettuata entro una Collection.
Ciascun elemento viene confrontato con tutti quelli che dalla
posizione successiva lo seguono: quando se ne trova uno minore
(se si deve ordinare in senso crescente) si scambiano i posti.
Ad esedmpio da:
4
3
2
1
si ottiene
3 3 2 2 2 1
4 2 3 3 1 2
2 4 4 1 3 3
1 1 1 4 4 4
Effettuando al massimo (4 - 1)! confronti.
La cosa migliore sarebbe stata quella di riportare i valori unici
contenuti nella Collection (NoDupes) in una range del foglio ed
ivi eseguire l'efficientissimo Sort di Excel.
Bruno
draleo
Esistono altri modi per ordinare una collection senza riversare nel foglio
i suoi valori per ordinarli ?
draleo
"Bruno Campanini" ha scritto:
> "draleo" <dra...@discussioni.com> wrote in message
Maurizio Borrelli
news:6B1C071F-0A44-432F...@microsoft.com:
> "Bruno Campanini" ha scritto:
[...]
> > > Questa è la parte di cui non capisco nulla e che credo effettui l'ordinamento
> > > For i = 1 To NoDupes.count - 1
> > > For j = i + 1 To NoDupes.count
> > > If NoDupes(i) > NoDupes(j) Then
> > > Swap1 = NoDupes(i)
> > > Swap2 = NoDupes(j)
> > > NoDupes.Add Swap1, before:=j
> > > NoDupes.Add Swap2, before:=i
> > > NoDupes.Remove i + 1
> > > NoDupes.Remove j + 1
> > > End If
> > > Next j
> > > Next i
> > Si tratta di un bubble-sort (la forma più intuitiva e meno efficiente
> > di sorting) effettuata entro una Collection.
> > Ciascun elemento viene confrontato con tutti quelli che dalla
> > posizione successiva lo seguono: quando se ne trova uno minore
> > (se si deve ordinare in senso crescente) si scambiano i posti.
[...]
> > Effettuando al massimo (4 - 1)! confronti.
> > La cosa migliore sarebbe stata quella di riportare i valori unici
> > contenuti nella Collection (NoDupes) in una range del foglio ed
> > ivi eseguire l'efficientissimo Sort di Excel.
> Esistono altri modi per ordinare una collection senza riversare nel foglio
> i suoi valori per ordinarli ?
Ciao draleo.
Perche' non ti domandi, prima, come e perche' ci sono finiti i dati
nella Collection?
--
Maurizio Borrelli [Microsoft MVP - Excel]
http://www.riolab.org/
Bruno Campanini
> Grazie mille
> Esistono altri modi per ordinare una collection senza riversare nel
> foglio
> i suoi valori per ordinarli ?
> draleo
Vuoi dire altri (più efficienti) algoritmi?
Serviti:
http://www.geocities.com/oosterwal/computer/sortroutines.html
Bruno
draleo
>Perche' non ti domandi, prima, come e perche' ci sono finiti i dati
>nella Collection?
Se intendi dire : perché non ordini i dati prima di caricarli nella
collection?
La risposta è che non posso farlo ,perché i dati originari fanno parte di un
range già ordinato con altri criteri e non posso disordinarlo (l’ordine
alfabetico mi serve solo nella listBox che attinge alla collection la quale,
a sua volta, attinge ai dati originari)
Potrebbe andare bene anche ordinare i dati UNIVOCI dopo che sono stati
caricati nella ListBox; ma come fare ad ordinare i dati di una listBox ?
grazie ad entrambi
draleo
Maurizio Borrelli
news:2686C7BD-CBEA-46C3...@microsoft.com:
> "Maurizio Borrelli" ha scritto:
Ciao draleo.
No, mi riferisco al fatto, segnalato anche da Bruno, che Excel possiede
tutti gli strumenti per copiare dati, ordinarli, ecc. Poi le ListBox si
collegano "naturalmente" a un intervallo di Excel. Basterebbe, nel tuo
caso, usare una Cartella di lavoro o un Foglio di lavoro temporaneo nel
quale copiare i dati necessari al popolamento della ListBox.
Non troppi giorni fa mi pare di aver postato un esempio. Appena posso
vedo di recuperarne il link.
r
"r" ha scritto:
premesso che
> personalmente utilizzerei la tua sub o qualcosa di simile (almeno come
> *indirizzo*)
per esempio ... una alternativa potrebbe essere
Sub CreaElencoUnivoco2()
Dim arr(), arr2()
arr = CreaVetUnivoco(ActiveSheet.Range("g2:i65535"))'range di esempio
arr2 = VetAZ(arr)
UserForm2.ListBox2.List() = arr2
End Sub
Function CreaVetUnivoco(Rng As Excel.Range) As Variant
Dim arr() As Variant
Dim NoDupes As New Collection
Dim i As Long, j As Long
Dim v As Variant
Dim index As Long
Dim d As Long
Dim p As Long
Dim vv As Excel.Range
ReDim arr(Rng.Count - 1)
For Each vv In Rng
arr(p) = CStr(vv.Value)
p = p + 1
Next
On Error Resume Next
Set NoDupes = New Collection
For index = LBound(arr) To UBound(arr)
NoDupes.Add 0, CStr(arr(index))
If Err Then
arr(index) = Empty
d = d + 1
Err.Clear
ElseIf d Then
arr(index - d) = arr(index)
arr(index) = Empty
End If
Next
If d Then
ReDim Preserve arr(LBound(arr) To UBound(arr) - d)
End If
On Error GoTo 0
Set NoDupes = Nothing
CreaVetUnivoco = arr
End Function
Function VetAZ(arr() As Variant) As Variant
Dim i As Long, a As Long, v As String
For i = 0 To UBound(arr) - 1
For a = i To UBound(arr)
If arr(i) > arr(a) Then
v = arr(i)
arr(i) = arr(a)
arr(a) = v
End If
Next
Next
VetAZ = arr
End Function
Maurizio Borrelli
news:#ILdg0kd...@TK2MSFTNGP02.phx.gbl:
> mi riferisco al fatto, segnalato anche da Bruno, che Excel possiede
> tutti gli strumenti per copiare dati, ordinarli, ecc. Poi le ListBox si
> collegano "naturalmente" a un intervallo di Excel. Basterebbe, nel tuo
> caso, usare una Cartella di lavoro o un Foglio di lavoro temporaneo nel
> quale copiare i dati necessari al popolamento della ListBox.
> Non troppi giorni fa mi pare di aver postato un esempio. Appena posso
> vedo di recuperarne il link.
Ciao draleo.
Boh... Chissa' dov'e' finito. Mi sa che non ho postato un bel niente.
Rimedio subito:
Dati di esempio:
[PopulateListBox.xls]
| A | B | C |
--+---------+-------+-------+
1 |Campo1 |Campo2 |Campo3 |
2 |Pippo | 1 | 3 |
3 |Pluto | 2 | 2 |
4 |Paperino | 3 | 1 |
5 |Topolino | 4 | 9 |
6 |Pippo | 5 | 8 |
_ __________________
\Foglio1/
Risultato atteso:
[UserForm1 ]
_______________
| +---------+ |
| |Paperino | |
| |Pippo | |
| |Pluto | |
| |Topolino | |
| +---------+ |
+-------------+
' UserForm1 - UserForm Class Module
'
' Controls:
' lboTest - ListBox
'
Option Explicit
Private Const cstrDataSheetName = "Foglio1"
Private Const cstrDataAddress = "A1"
Private rngLboSource As Excel.Range
Private wbkTemp As Excel.Workbook
Private wshTemp As Excel.Worksheet
Private Sub PopulateLboTest()
Dim rngIn As Excel.Range
With rngLboSource
Set rngIn = .Range(.Item(1) _
, .End(xlDown))
End With
With wshTemp.Range("A1")
rngIn.AdvancedFilter Action:=xlFilterCopy _
, CopyToRange:=.Item(1) _
, Unique:=True
With .Range(.Offset(1), .End(xlDown))
.Sort Key1:=.Item(1) _
, Order1:=xlAscending _
, Header:=xlNo _
, OrderCustom:=1 _
, MatchCase:=False _
, Orientation:=xlTopToBottom _
, DataOption1:=xlSortNormal
Me.lboTest.RowSource = "'[" & wbkTemp.Name & "]" _
& wshTemp.Name & "'!" _
& .Address
End With
End With
Set rngIn = Nothing
End Sub
Private Sub UserForm_Initialize()
With ThisWorkbook.Application
Set rngLboSource = .Range("'[" & .ThisWorkbook.Name & "]" _
& cstrDataSheetName & "'" _
& "!" & cstrDataAddress)
Set wbkTemp = .Workbooks.Add
.ActiveWindow.Visible = False
End With
Set wshTemp = wbkTemp.Worksheets.Item(1)
PopulateLboTest
End Sub
Private Sub UserForm_Terminate()
wbkTemp.Close SaveChanges:=False
Set wbkTemp = Nothing
Set wbkTemp = Nothing
Set rngLboSource = Nothing
End Sub
r
"Maurizio Borrelli" ha scritto:
>
> Boh... Chissa' dov'e' finito. Mi sa che non ho postato un bel niente.
> Rimedio subito:
che dire ... notevole!
direi che è assolutamente migliore di quanto sinora proposto ...
non pensavo potesse essere così rapido ... la chiave credo sia nel filtro
considerando la volontà di riportare in una listbox il risultato supponevo
già che la lista non fosse molto lunga e il tempo dell'ordinamento lo
reputavo nn significativo ... credo che anche utilizzando un algoritmo di
sort più efficiente il tempo di esecuzione non sarebbe variato in modo
significativo ...
mi piacerebbe capirne di più su come ragiona *Excel* ... vabeh :-)
...
permetti una domanda
volessi considerare più colonne ... ovvero considerare dati univoci ordinati
in un range a più colonne si potrebbe risolvere in modo altrettanto elegante
e rapido?
grazie e ciao
r
Maurizio Borrelli
news:A5781B40-02C1-4136...@microsoft.com:
> "Maurizio Borrelli" ha scritto:
Ciao r.
> > Boh... Chissa' dov'e' finito. Mi sa che non ho postato un bel niente.
> > Rimedio subito:
[...]
> che dire ... notevole!
> direi che è assolutamente migliore di quanto sinora proposto ...
Necessariamente. Uei... Non fraintendermi. ;-) Intendo necessariamente
perche' negli altri modi si usano tre elementi "lenti": il popolamento
di Array cella per cella, la VBA.Collection, l'ordinamento con
l'algoritmo meno efficiente che esista.
> non pensavo potesse essere così rapido ... la chiave credo sia nel filtro
Anche qui son tre le cose da considerare, e tutte e tre native di Excel:
l'estrazione di elementi univoci, l'ordinamento, il popolamento
"diretto" della ListBox agganciata a un Range, cosa quest'ultima
particolarmente efficiente.
> considerando la volontà di riportare in una listbox il risultato supponevo
> già che la lista non fosse molto lunga e il tempo dell'ordinamento lo
> reputavo nn significativo ... credo che anche utilizzando un algoritmo di
> sort più efficiente il tempo di esecuzione non sarebbe variato in modo
> significativo ...
> mi piacerebbe capirne di più su come ragiona *Excel* ... vabeh :-)
> ...
> permetti una domanda
> volessi considerare più colonne ... ovvero considerare dati univoci ordinati
> in un range a più colonne si potrebbe risolvere in modo altrettanto elegante
> e rapido?
La struttura che ho proposto rimane inviariata. Si tratta solo di
definire opportunamente gli intervalli . Appena posso...
r
ciao
r
p.s.
un po' di tempo fa avevo cercato un algoritmo vb di quicksort ... quindi un
grazie a Bruno per il link utilissimo
Sub CreaElencoUnivoco2()
Dim arr(), arr2()
arr = CreaVetUnivoco(ActiveSheet.Range("a1:d65536")) 'range di esempio
arr2 = QVetAZ(arr) 'VetAZ(arr)
UserForm1.ListBox1.List() = arr2
End Sub
Function CreaVetUnivoco(Rng As Excel.Range) As Variant
Dim arr() As Variant, arr2()
Dim NoDupes As New Collection
Dim I As Long, J As Long
Dim v As Variant
Dim index As Long
Dim d As Long
Dim p As Long
Dim vv As Excel.Range
Dim Ncol As Long
Dim c As Long
ReDim arr(Rng.Count - 1)
'For Each vv In Rng
'arr(p) = CStr(vv.Value)
'p = p + 1
'Next
arr2 = Rng
On Error Resume Next
Set NoDupes = New Collection
For Ncol = 1 To UBound(arr2, 2)
For index = LBound(arr2) To UBound(arr2)
NoDupes.Add 0, CStr(arr2(index, Ncol))
If Err Then
'arr(index) = Empty
d = d + 1
Err.Clear
Else
arr(c) = arr2(index, Ncol)
c = c + 1
'arr(index) = Empty
End If
Next
Next
If d Then
ReDim Preserve arr(LBound(arr) To UBound(arr) - d)
End If
On Error GoTo 0
Set NoDupes = Nothing
CreaVetUnivoco = arr
End Function
Function QVetAZ(InTarray() As Variant) As Variant
Dim I, J, Temp As Variant
Dim LeftStack(32), RightStack(32), LeftIndex, RightIndex As Long
Dim StackPointer, IntValue As Variant
LeftIndex = 0
RightIndex = UBound(InTarray)
StackPointer = 1
LeftStack(StackPointer) = LeftIndex
RightStack(StackPointer) = RightIndex
Do
If RightIndex > LeftIndex Then
IntValue = InTarray(RightIndex)
I = LeftIndex - 1
J = RightIndex
Do
Do: I = I + 1: Loop Until InTarray(I) >= IntValue
Do: J = J - 1: Loop Until J = LeftIndex Or InTarray(J) <=
IntValue
Temp = InTarray(I)
InTarray(I) = InTarray(J)
InTarray(J) = Temp
Loop Until J <= I
Temp = InTarray(J)
InTarray(J) = InTarray(I)
InTarray(I) = InTarray(RightIndex)
InTarray(RightIndex) = Temp
StackPointer = StackPointer + 1
If (I - LeftIndex) > (RightIndex - I) Then
LeftStack(StackPointer) = LeftIndex
RightStack(StackPointer) = I - 1
LeftIndex = I + 1
Else
LeftStack(StackPointer) = I + 1
RightStack(StackPointer) = RightIndex
RightIndex = I - 1
End If
Else
LeftIndex = LeftStack(StackPointer)
RightIndex = RightStack(StackPointer)
StackPointer = StackPointer - 1
If StackPointer = 0 Then Exit Do
End If
Loop
QVetAZ = InTarray
End Function
Function VetAZ(arr() As Variant) As Variant
Dim I As Long, a As Long, v As String
For I = 0 To UBound(arr) - 1
For a = I To UBound(arr)
If arr(I) > arr(a) Then
v = arr(I)
arr(I) = arr(a)
Maurizio Borrelli
news:3B678D5F-1C3A-4D64...@microsoft.com:
Ciao r.
> effettivamente lavorando un po' sui tre punti ... qualcosa si migliora ...
> p.s.
> un po' di tempo fa avevo cercato un algoritmo vb di quicksort ... quindi un
> grazie a Bruno per il link utilissimo
Eccotene un altro:
[Sort] Quicksort non ricorsivo
http://www.it-lang-vb.net/Archivio/FAQ/FAQ00061.HTM
Maurizio Borrelli
[...]
> > volessi considerare più colonne ... ovvero considerare dati univoci ordinati
> > in un range a più colonne si potrebbe risolvere in modo altrettanto elegante
> > e rapido?
> La struttura che ho proposto rimane inviariata. Si tratta solo di
> definire opportunamente gli intervalli . Appena posso...
Ciao r.
Oltre che la possibilita' valori univoci su piu' colonne, che e'
sostanzialmente una variante del'altra, forse piu' su nella hit-parade
c'e' la questione del raggruppamento. Ovvero, coi dati dell'esempio
dell'altro post:
[PopulateListBox.xls]
| A | B | C |
--+---------+-------+-------+
1 |Campo1 |Campo2 |Campo3 |
2 |Pippo | 1 | 3 |
3 |Pluto | 2 | 2 |
4 |Paperino | 3 | 1 |
5 |Topolino | 4 | 9 |
6 |Pippo | 5 | 8 |
_ __________________
\Foglio1/
Ottenere:
[UserForm1 ]
___________________
| +-------------+ |
| |Paperino | 1| |
| |Pippo |11| |
| |Pluto | 2| |
| |Topolino | 9| |
| +-------------+ |
+-----------------+
Cioe' i valori univoci di Campo1 e i subtotali di Campo3 di ciascuno.
Un modo, sempre limitandomi a evidenziare la "struttura" del problema,
senza gestione errori, eccezioni e balle e biglie:
' UserForm2 - UserForm Class Module
'
' Controls:
' lboTest - ListBox
'
Option Explicit
Private Const cstrDataSheetName = "Foglio1"
Private Const cstrDataAddress = "A1"
Private rngLboSource As Excel.Range
Private wbkTemp As Excel.Workbook
Private wshTemp As Excel.Worksheet
Private strDbParentAddress As String
Private Sub PopulateLboTest()
Dim rngIn As Excel.Range
Dim strTempParentAddress As String
strTempParentAddress = "'[" & wbkTemp.Name & "]" _
& wshTemp.Name & "'!"
With rngLboSource
Set rngIn = .Range(.Item(1) _
, .End(xlDown))
End With
With wshTemp.Range("A1")
rngIn.AdvancedFilter Action:=xlFilterCopy _
, CopyToRange:=.Item(1) _
, Unique:=True
With rngIn
Set rngIn = .Offset(1).Resize(.Rows.Count - 1)
End With
With .Range(.Offset(1), .End(xlDown))
.Sort Key1:=.Item(1) _
, Order1:=xlAscending _
, Header:=xlNo _
, OrderCustom:=1 _
, MatchCase:=False _
, Orientation:=xlTopToBottom _
, DataOption1:=xlSortNormal
.Offset(0, 1).Formula = "=SUMIF(" _
& strDbParentAddress & rngIn.Address _
& "," _
& """=""&A2" _
& "," _
& strDbParentAddress & rngIn.Offset(0, 2).Address _
& ")"
Me.lboTest.RowSource = strTempParentAddress _
& .Resize(.Rows.Count _
, 2).Address
End With
End With
Me.lboTest.ColumnCount = 2
Set rngIn = Nothing
End Sub
Private Sub UserForm_Initialize()
With ThisWorkbook.Application
strDbParentAddress = "'[" & .ThisWorkbook.Name & "]" _
& cstrDataSheetName & "'!"
Set rngLboSource = .Range(strDbParentAddress _
& cstrDataAddress)
Set wbkTemp = .Workbooks.Add
.ActiveWindow.Visible = False
End With
Set wshTemp = wbkTemp.Worksheets.Item(1)
PopulateLboTest
End Sub
Private Sub UserForm_Terminate()
wbkTemp.Close SaveChanges:=False
Set wbkTemp = Nothing
Set wbkTemp = Nothing
Set rngLboSource = Nothing
End Sub
' modTest - Standard Module
'
Option Explicit
Public Sub Test1()
Dim frm As UserForm1
Set frm = New UserForm1
frm.Show vbModal
Set frm = Nothing
End Sub
Public Sub Test2()
Dim frm As UserForm2
Set frm = New UserForm2
frm.Show vbModal
Set frm = Nothing
End Sub
Maurizio Borrelli
> Oltre che la possibilita' valori univoci su piu' colonne, che e'
> sostanzialmente una variante del'altra, forse piu' su nella hit-parade
> c'e' la questione del raggruppamento. Ovvero, coi dati dell'esempio
> dell'altro post:
[...]
> Ottenere:
[...]
> Cioe' i valori univoci di Campo1 e i subtotali di Campo3 di ciascuno.
Preciso: quello dei subtotali e' solo un esempio dei pressocche'
infiniti raggruppamenti possibili!...
r
"Maurizio Borrelli" ha scritto:
leggerò con attenzione il codice ... ma sinceramente non riesco a immaginare
un metodo *semplice* per gestire il problema su un range di più colonne ...
per intenderci mettiamo un range come nel mio esempio a1:c65536 e
considerando tutti i valori come unico insieme da filtrare come univoco e poi
ordinare ...
non è necessario che mi scriva il codice (anche se sarebbe ben accetto:-)
... basterebbe indicarmi i passaggi logici ...
grazie e ciao
r
r
"r" ha scritto:
> effettivamente lavorando un po' sui tre punti ... qualcosa si migliora ...
> ciao
> r
intanto ancora io lentamente ottimizzo (spero) la mia versione ...
quindi la funzione CreaVetUnivoco diventa ...
Function CreaVetUnivoco(Rng As Excel.Range) As Variant
Dim arr() As Variant, arr2()
Dim NoDupes As New Collection
Dim I As Long, J As Long
Dim v As Variant
Dim index As Long
Dim d As Long
Dim p As Long
Dim vv As Excel.Range
Dim Ncol As Long
Dim c As Long
ReDim arr(Rng.Count - 1)
arr2 = Rng
On Error Resume Next
Set NoDupes = New Collection
For Ncol = 1 To UBound(arr2, 2)
For index = LBound(arr2) To UBound(arr2)
NoDupes.Add 0, CStr(arr2(index, Ncol))
If Err Then
Err.Clear
Else
arr(c) = arr2(index, Ncol)
c = c + 1
End If
Next
Next
On Error GoTo 0
ReDim Preserve arr(c - 1)
r
"Maurizio Borrelli" ha scritto:
... grazie mille
r
Maurizio Borrelli
news:FC6AF743-C002-4E6A...@microsoft.com:
> "Maurizio Borrelli" ha scritto:
[...]
> > > Oltre che la possibilita' valori univoci su piu' colonne, che e'
> > > sostanzialmente una variante del'altra, forse piu' su nella hit-parade
> > > c'e' la questione del raggruppamento. Ovvero, coi dati dell'esempio
> > > dell'altro post:
> > [...]
> > > Ottenere:
> > [...]
> > > Cioe' i valori univoci di Campo1 e i subtotali di Campo3 di ciascuno.
> > Preciso: quello dei subtotali e' solo un esempio dei pressocche'
> > infiniti raggruppamenti possibili!...
> leggerň con attenzione il codice ... ma sinceramente non riesco a immaginare
> un metodo *semplice* per gestire il problema su un range di piů colonne ...
> per intenderci mettiamo un range come nel mio esempio a1:c65536 e
> considerando tutti i valori come unico insieme da filtrare come univoco e poi
> ordinare ...
> non č necessario che mi scriva il codice (anche se sarebbe ben accetto:-)
> ... basterebbe indicarmi i passaggi logici ...
Ciao r.
Mi sembra ci sia qualcosa che non quadra nel tuo discorso. Con i dati
seguenti:
[PopulateListBox.xls]
| A | B | C |
--+---------+-------+-------+
1 |Campo1 |Campo2 |Campo3 |
2 |Pippo | 1 | 3 |
3 |Pluto | 2 | 2 |
4 |Paperino | 3 | 1 |
5 |Topolino | 4 | 9 |
6 |Pippo | 5 | 8 |
_ __________________
\Foglio1/
se ho capito bene, vorresti ottenere il seguente risultato:
|Pippo | 1 | 3 |
|Pluto | 2 | 2 |
|Paperino | 3 | 1 |
|Topolino | 4 | 9 |
|Pippo | 5 | 8 |
E' cosi'?
Maurizio Borrelli
news:588DC1A2-01CE-4D47...@microsoft.com:
> > effettivamente lavorando un po' sui tre punti ... qualcosa si migliora ...
Ciao r.
Questione di priorita'... e di costi. Anche riuscissi a ottenere un
risultato due volte migliore e almeno altrettanto affidabile di quello
ottenibile con le funzioni interne di Excel... Chi te lo "paga"...
ammesso tu riesca a "venderlo"? (Nota bene che ho usato le virgolette,
quindi NON prendermi alla lettera, o almeno non solo alla lettera. Ti
faccio notare che anche se tu "lavorando" NON l'hai messo fra virgolette
io comunque NON ti ho preso alla lettera. ;-)
r
"Maurizio Borrelli" ha scritto:
> "r" wrote in message
> news:FC6AF743-C002-4E6A...@microsoft.com:
> > "Maurizio Borrelli" ha scritto:
>
> [...]
> > > > Oltre che la possibilita' valori univoci su piu' colonne, che e'
> > > > sostanzialmente una variante del'altra, forse piu' su nella hit-parade
> > > > c'e' la questione del raggruppamento. Ovvero, coi dati dell'esempio
> > > > dell'altro post:
> > > [...]
> > > > Ottenere:
> > > [...]
> > > > Cioe' i valori univoci di Campo1 e i subtotali di Campo3 di ciascuno.
> > > Preciso: quello dei subtotali e' solo un esempio dei pressocche'
> > > infiniti raggruppamenti possibili!...
> > leggerò con attenzione il codice ... ma sinceramente non riesco a immaginare
> > un metodo *semplice* per gestire il problema su un range di più colonne ...
> > per intenderci mettiamo un range come nel mio esempio a1:c65536 e
> > considerando tutti i valori come unico insieme da filtrare come univoco e poi
> > ordinare ...
> > non è necessario che mi scriva il codice (anche se sarebbe ben accetto:-)
col1 col2 col3
a b c
d e e
f a r
....
vorrei ottenere
a
b
c
d
e
f
r
che è quello che avevo capito volesse fare l'autore della domanda ...
(mi riferisco a quella riga di codice dove era scritto
arr=rng.resize(,3) ... forse mal interpretato? )
ciao e grazie
r
Maurizio Borrelli
news:855965AC-926D-4CBD...@microsoft.com:
> "Maurizio Borrelli" ha scritto:
[...]
> > Mi sembra ci sia qualcosa che non quadra nel tuo discorso.
[...]
> col1 col2 col3
> a b c
> d e e
> f a r
> ....
> vorrei ottenere
> a
> b
> c
> d
> e
> f
> r
> che è quello che avevo capito volesse fare l'autore della domanda ...
> (mi riferisco a quella riga di codice dove era scritto
> arr=rng.resize(,3) ... forse mal interpretato? )
Ciao r.
Togli pure il "forse" e consulta la Guida a proposito di:
Property Resize([RowSize], [ColumnSize]) As Range
sola lettura
Membro di Excel.Range
poi nella finestra Immediata digita:
?range("A1:A100").Resize(,3).Address
e concludi l'immissione con Invio.
r
"Maurizio Borrelli" ha scritto:
non capisco ... il risultato è quello che mi attendevo
$A$1:$C$100
non capisco dove sbaglio ...
ciao
r
Maurizio Borrelli
news:855965AC-926D-4CBD...@microsoft.com:
> "Maurizio Borrelli" ha scritto:
[...]
> (mi riferisco a quella riga di codice dove era scritto
> arr=rng.resize(,3) ... forse mal interpretato? )
Ciao r.
Sono andato a riguardare quel codice... Di tutte le istruzioni di cui e'
composto sei andato a beccare proprio l'unica "morta". Queste sono le
uniche linee di codice in cui compare la variabile "arr":
Public arr As Variant
Sub CreaElencoUnivoco()
' [...]
arr = Rng.Resize(, 3)
' [...]
End Sub
Dici che serva a qualcosa, nel contesto del nostro discorso?...
Maurizio Borrelli
news:75DDECEC-C961-48DC...@microsoft.com:
> "Maurizio Borrelli" ha scritto:
[...]
> > > > Mi sembra ci sia qualcosa che non quadra nel tuo discorso.
[...]
> > > col1 col2 col3
> > > a b c
> > > d e e
> > > f a r
> > > ....
> > > vorrei ottenere
> > > a
> > > b
> > > c
> > > d
> > > e
> > > f
> > > r
> > > che č quello che avevo capito volesse fare l'autore della domanda ...
[...]
> non capisco dove sbaglio ...
Ciao r.
Neppur'io so dove sbagli, perche' non so a cosa ti riferisci. Poco fa ho
appreso che stai lavorando su una tabella che non e' una tabella ma un
unico "campo" su tre colonne (!) mentre questo 3D era partito da qui:
'Nel foglio "statis accertamenti" ,dalla cella G13 in giů, ho un Elenco
di voci (stringhe) NON ORDINATE contenente molti voci duplicate Dovendo
caricare una listBox con tali dati UNIVOCI e ORDINATI alfabeticamente,
[...]'.
Tu come sei arrivato al "campo su tre colonne"?
r
"Maurizio Borrelli" ha scritto:
ok ... ci siamo ufff... :-)
naturalmente era un istruzione morta ... ma ho letto nelle intenzioni
dell'autore il senso spiegato prima ...
così mi è nato il tarlo che ho cercato di risolvere ... ne ho approfittato
perchè in un vecchio mio progetto mi trovai di fronte a matrici molto grandi
... così ...
questo è quanto ...
quindi mi interessa ... al di la che sia il problema dell'autore o no ... la
tua opinione in quel caso ....
grazie ancora per il tempo dedicato
ciao
r
p.s. adesso vado al cinema a vedere il film vincitore dell'oscar ... mi
hanno detto che merita ... quindi ... a questa notte se ci sarai.
draleo
> Boh... Chissa' dov'e' finito…
Sono sparito per mezza giornata (purtroppo devo dedicarmi anche al mio vero
lavoro) e alla riaccensione del computer trovo questi capolavori del VBA
Eccezionale… Troppa Grazia S.Antonio…Non speravo tanto !!
Grazie per avermi dedicato il vostro tempo e il vostro cervello
I 2 listati proposti sono ottimi e penso che mi occorrerà l’intera
nottata per studiarli.
Alcune considerazioni:
1)soluzione di r
crea nella listBox un elenco univoco ed ordinato dei valori di più colonne
di un range . Funziona benissimo , ma mi presenta una piccola imperfezione:
la prima riga della listBox viene sempre vuota. Dove correggere il listato
di r per eliminare questo difetto?
2) Soluzione di Maurizio
le cose sono più complicate da capire , per lo meno per me che sono un
apprendista. Lo studierò con calma . Per ora tre quesiti
a) Ad una prima esecuzione, sicuramente per colpa mia, mi da errore alla riga:
>Me.lboTest.RowSource = "'[" & wbkTemp.Name & "]" _
Errore di compilazione:impossibile trovare il metodo o il membro dei dati
b) Inoltre le prime tre righe sembrano commentate. È così ? oppure ho mal
interpretato il discorso ?
>' UserForm1 - UserForm Class Module
>' Controls:
>' lboTest – ListBox
c) La seguente parte del listato dove va messa ? In un modulo o nel codice
della UserForm?
Option Explicit
Private Const cstrDataSheetName = "Foglio1"
Private Const cstrDataAddress = "A1"
Private rngLboSource As Excel.Range
Private wbkTemp As Excel.Workbook
Private wshTemp As Excel.Worksheet
Private Sub PopulateLboTest()
Dim rngIn As Excel.Range
With rngLboSource
Set rngIn = .Range(.Item(1) _
, .End(xlDown))
End With
With wshTemp.Range("A1")
rngIn.AdvancedFilter Action:=xlFilterCopy _
, CopyToRange:=.Item(1) _
, Unique:=True
With .Range(.Offset(1), .End(xlDown))
.Sort Key1:=.Item(1) _
, Order1:=xlAscending _
, Header:=xlNo _
, OrderCustom:=1 _
, MatchCase:=False _
, Orientation:=xlTopToBottom _
, DataOption1:=xlSortNormal
Me.lboTest.RowSource = "'[" & wbkTemp.Name & "]" _
& wshTemp.Name & "'!" _
& .Address
End With
End With
Set rngIn = Nothing
End Sub
grazie ancora ad entrambi
draleo
Maurizio Borrelli
news:1644335B-3AF6-49BB...@microsoft.com:
> "Maurizio Borrelli" ha scritto:
[...]
> > > (mi riferisco a quella riga di codice dove era scritto
> > > arr=rng.resize(,3) ... forse mal interpretato? )
[...]
> cosě mi č nato il tarlo che ho cercato di risolvere ... ne ho approfittato
> perchč in un vecchio mio progetto mi trovai di fronte a matrici molto grandi
> ... cosě ...
> questo č quanto ...
> quindi mi interessa ... al di la che sia il problema dell'autore o no ... la
> tua opinione in quel caso ....
Ciao r.
Giusto per variare ogni tanto... un modo, che non mi entusiasma troppo,
potrebbe essere:
' modTest - Standard Module
'
Option Explicit
Public Sub Test()
Dim dicIn As Object 'Scripting.Dictionary
Dim rngIn As Excel.Range
Dim rngOut As Excel.Range
Dim rngRow As Excel.Range
Dim rng As Excel.Range
Dim vntItem As Variant
Set dicIn = CreateObject("Scripting.Dictionary")
dicIn.CompareMode = TextCompare
With Foglio1
With .Range("A1")
Set rngIn = .Range(.Cells(1, 1) _
, .End(xlDown) _
).Resize(, 3)
End With
Set rngOut = .Range("E1")
End With
rngOut.EntireColumn.Clear
Application.ScreenUpdating = False
For Each rngRow In rngIn.Rows
For Each rng In rngRow.Cells
vntItem = rng.Value
With dicIn
If Not .Exists(vntItem) Then .Add vntItem _
, vntItem
End With
Next
Next
With dicIn
Set rngOut = rngOut.Resize(.Count)
For Each rng In rngOut
rng.Value = .Items
.Remove rng.Value
Next
End With
rngOut.Sort rngOut, xlAscending
Application.ScreenUpdating = True
Set rng = Nothing
Set rngRow = Nothing
Set rngOut = Nothing
Set rngIn = Nothing
Set dicIn = Nothing
End Sub
Maurizio Borrelli
news:CC73825A-B5E9-4294...@microsoft.com:
> >"Maurizio Borrelli" ha scritto:
Ciao draleo.
> Grazie per avermi dedicato il vostro tempo e il vostro cervello
Grazie a te, da parte di entrambi. ;-)
> I 2 listati proposti sono ottimi e penso che mi occorrerà l'intera
> nottata per studiarli.
> Alcune considerazioni:
> 1)soluzione di r
Passo.
> 2) Soluzione di Maurizio
[...]
> a) Ad una prima esecuzione, sicuramente per colpa mia, mi da errore alla riga:
> >Me.lboTest.RowSource = "'[" & wbkTemp.Name & "]" _
> Errore di compilazione:impossibile trovare il metodo o il membro dei dati
Vedi sotto.
> b) Inoltre le prime tre righe sembrano commentate. È così ? oppure ho mal
> interpretato il discorso ?
Sono commentate perche' sono commenti. Piu' esattamente con quei
commenti io ti informo riguardo cosa devi fare del codice che le segue.
> >' UserForm1 - UserForm Class Module
Traduzione: il listato va copiato nel modulo di uno UserForm di nome
UserForm1.
> >' Controls:
Traduzione: prima di eseguire dovrai aggiungere allo UserForm in
questione i controlli indicati di seguito.
> >' lboTest - ListBox
Traduzione: aggiungi un controllo di tipo ListBox al quale assegnerai il
nome lboTest.
> c) La seguente parte del listato dove va messa ?
Ora dovrebbe esser chiaro. Giusto?
r
"draleo" ha scritto:
> Grazie per avermi dedicato il vostro tempo
ho trovato diversi spunti nel tuo codice ... ed egoisticamente parlando il
tempo dedicato è servito a me quanto a te :-)
> 1)soluzione di r
la mia soluzione ha avute a mio avviso diverse migliorie durante lo scambio
con Maurizio quindi se ti interessa ti consiglio di rileggere quella parte
... e comunque non lo considero ancora definitivo (sto ancora lavorando
sull'algoritmo ... voglio provare a inserire l'ordinamento nella fase di
caricamento del vettore e vedere se mi porta a un miglioramento delle
prestazioni, ancora molto distanti dalla soluzione di M. solo nel caso di un
elenco univoco *numeroso*)
> di r per eliminare questo difetto?
non è un difetto ... semplicemente considera anche il valore "" come
risultato ... se nel tuo range non ci fossero campi vuoti infatti non
risulterebbe nemmeno nella list ... comunque se per te è un problema si può
facilmente risolvere ...
grazie e ciao
r
Maurizio Borrelli
[...]
> Giusto per variare ogni tanto... un modo, che non mi entusiasma troppo,
> potrebbe essere:
[...]
Ciao r.
Riscritto un po' meglio:
' modTest - Standard Module
'
Option Explicit
Public Sub Test()
Dim dicIn As Scripting.Dictionary
Dim rngIn As Excel.Range
Dim rngOut As Excel.Range
Dim rngRow As Excel.Range
Dim rng As Excel.Range
Dim vntItem As Variant
Dim i As Long
Set dicIn = New Scripting.Dictionary
dicIn.CompareMode = vbTextCompare
With Foglio1
With .Range("A1")
Set rngIn = .Range(.Cells(1, 1) _
, .End(xlDown) _
).Resize(, 3)
End With
Set rngOut = .Range("E1")
End With
rngOut.EntireColumn.Clear
Application.ScreenUpdating = False
For Each rngRow In rngIn.Rows
For Each rng In rngRow.Cells
vntItem = rng.Value
With dicIn
If Not .Exists(vntItem) Then .Item(vntItem) = vntItem
End With
Next
Next
For Each vntItem In dicIn.Items
rngOut.Offset(i).Value = vntItem
i = i + 1
Next
Maurizio Borrelli
[...]
> > Giusto per variare ogni tanto... un modo, che non mi entusiasma troppo,
> > potrebbe essere:
[...]
> Riscritto un po' meglio:
[...]
> For Each vntItem In dicIn.Items
> rngOut.Offset(i).Value = vntItem
> i = i + 1
> Next
> rngOut.Sort rngOut, xlAscending
[...]
... e, per cominciare a dare all'abbozzo un po' piu' di robustezza e
renderlo piu' generale si potrebbe sostituire il blocco che ho quotato
con questo:
If dicIn.Count Then
For Each vntItem In dicIn.Items
rngOut.Offset(i).Formula = UCase$(vntItem)
i = i + 1
Next
If i > 1 Then
rngOut.End(xlDown).Sort rngOut _
, xlAscending _
, Header:=xlNo
End If
End If
Maurizio Borrelli
[...]
> Dim dicIn As Scripting.Dictionary
[...]
> Set dicIn = New Scripting.Dictionary
[...]
[Dal mio post (26/02/2008 00.05) in questo 3D]
[...]
Dim dicIn As Object 'Scripting.Dictionary
[...]
Set dicIn = CreateObject("Scripting.Dictionary")
[...]
Una piccola annotazione penso meritino queste righe di codice, che fanno
la stessa cosa pero' in modo diverso.
L'usare il Late Binding con la:
Library Scripting
[...]\scrrun.dll
Microsoft Scripting Runtime
e' piu' che altro, ormai, un'abitudine piu' che una reale esigenza.
Abitudine che risale ai tempi antichi di Windows 95/98 quando poteva
capitare di dover far girare il codice in macchine che non avessero
installato le Library di Scripting. Abitudine che torna utile quando si
posta codice nei ng e si vuole evitare la rogna di spiegare come
aggiungere una Library ai riferimenti del progetto.
Oggi pero' e' decisamente improbabile trovare una macchina priva di tali
Library quindi e' sicuramente piu' opportuno aggiungere tale riferimento
e beneficiare cosi' dell'Early Binding.
Maurizio Borrelli
news:F32C4DB4-1A15-44CA...@microsoft.com:
> "Maurizio Borrelli" ha scritto:
Ciao r.
> > Set rngOut = .Range("E1")
> ciao Maurizio e grazie per gli spunti ... ho attivato il riferimento a
> Microsoft scripting runtime ma non riesco a visualizzare la guida ...
> comunque mi sembra d'aver capito il senso ...
> non ho ancora valutato tutto il codice ma la riga di qui sopra non risolve
> il problema ... dovresti comunque considerare che i possibili risultati siano
> più di 65536 ...
Perche' mai devo considerare una simile mostruosita'?... ;-)
Stiamo parlando di popolamento di ListBox/ComboBox o che? Stiamo
parlando di Excel... o che?
r
"Maurizio Borrelli" ha scritto:
> "r" wrote in message
> news:F32C4DB4-1A15-44CA...@microsoft.com:
> > "Maurizio Borrelli" ha scritto:
>
> Ciao r.
>
> > > Set rngOut = .Range("E1")
> > ciao Maurizio e grazie per gli spunti ... ho attivato il riferimento a
> > Microsoft scripting runtime ma non riesco a visualizzare la guida ...
>
> http://groups.google.com/group/microsoft.public.it.office.excel/tree/browse_frm/thread/f85dd555e3812fc3
anche aggiungendo i riferimentio a vbscript globals ... la guida in linea
(da f1) non funziona ... tempo fa avevo tentato di risolvere un problema
analogo con le librerie ado ma anche in quel caso non ero riuscito ... bah
> > comunque mi sembra d'aver capito il senso ...
> > non ho ancora valutato tutto il codice ma la riga di qui sopra non risolve
> > il problema ... dovresti comunque considerare che i possibili risultati siano
> > più di 65536 ...
>
> Perche' mai devo considerare una simile mostruosita'?... ;-)
dal momento che consideri range a più colonne ...
>
> Stiamo parlando di popolamento di ListBox/ComboBox o che? Stiamo
> parlando di Excel... o che?
collection, matrici, algoritmi sort ... diciamo che stiamo spaziando un po'
:-)
ok grazie ancora
ciao
r
p.s.
la tua seconda non ordina e non riesco a capire perchè
Maurizio Borrelli
news:FCECF8E8-8476-4745...@microsoft.com:
> "Maurizio Borrelli" ha scritto:
Ciao r.
> > > > Set rngOut = .Range("E1")
> > > ciao Maurizio e grazie per gli spunti ... ho attivato il riferimento a
> > > Microsoft scripting runtime ma non riesco a visualizzare la guida ...
> > http://groups.google.com/group/microsoft.public.it.office.excel/tree/browse_frm/thread/f85dd555e3812fc3
> anche aggiungendo i riferimentio a vbscript globals ... la guida in linea
> (da f1) non funziona ... tempo fa avevo tentato di risolvere un problema
> analogo con le librerie ado ma anche in quel caso non ero riuscito ... bah
Idem. Tutto sommato la cosa non mi crea grossi problemi. Uso MSDN in
Visual Studio (6.0 o 2005). Ad ogni buon conto ho messo il collegamento
a VBSCRIP5.CHM sul Desktop...
> > > comunque mi sembra d'aver capito il senso ...
> > > non ho ancora valutato tutto il codice ma la riga di qui sopra non risolve
> > > il problema ... dovresti comunque considerare che i possibili risultati siano
> > > più di 65536 ...
> > Perche' mai devo considerare una simile mostruosita'?... ;-)
> dal momento che consideri range a più colonne ...
> > Stiamo parlando di popolamento di ListBox/ComboBox o che? Stiamo
> > parlando di Excel... o che?
> collection, matrici, algoritmi sort ... diciamo che stiamo spaziando un po'
> :-)
Sarebbe opportuno spaziare entro limiti ben definiti. Io come limite mi
pongo i limiti di Excel. Se vuoi, puoi prendere come riferimento la
versione 2007 cosi' puoi andare oltre 65536, tuttavia con tali volumi e'
meglio *prima* chiarire moto bene gli scopi che si vuole raggiungere.
Altrimenti rischiamo di usare lo strumento sbagliato, Excel+VB invece
che San Database.
> p.s.
> la tua seconda non ordina e non riesco a capire perchè
A me si'. E la terza?
r
ciao Maurizio
ecco la mia versione *definitiva* ... permette di considerare range anche di
più colonne non avendo limiti se non quelli di owerflow
su un range a colonna singola è veloce (da 0.4 sec. circa a 2,5 sec quando
il risultato supera 60000 voci) e con l'algoritmo Shellsort permette di
ottimizzare anche quando l'elenco è già parzialmente ordinato .... ho
verificato che è di gran lunga più veloce del quicksort su vettori univoci
come in questo caso ... ho aggiunto (come da richiesta:-) la *clausola* di
eliminare dall'elencola riga vuota ...
... che dire ... mi ritengo soddisfatto dello scambio didattico nel quale ho
imparato molto ...
quindi un grazie ad entrambi
ciao
r
Sub CreaElencoUnivoco2()
Dim arr(), arr2()
arr = CreaVetUnivoco(ActiveSheet.Range("a1:e65536")) 'range di esempio
arr2 = Shell_m_VetAZ(arr) 'QVetAZ(arr) 'VetAZ(arr)
UserForm1.ListBox1.List() = arr2
End Sub
Function Shell_m_VetAZ(arr() As Variant) As Variant
Dim value, index As Long, index2 As Long
Dim ultimo As Long
Dim primo As Long
Dim metro As Long
Dim tot As Long
primo = LBound(arr)
ultimo = UBound(arr)
tot = ultimo - primo + 1
Do
metro = metro * 3 + 1
Loop Until metro > tot
Do
metro = metro / 3
For index = metro + primo To ultimo
value = arr(index)
index2 = index
Do While (arr(index2 - metro) > value) Xor False
arr(index2) = arr(index2 - metro)
index2 = index2 - metro
If index2 - metro < primo Then Exit Do
Loop
arr(index2) = value
Next
Loop Until metro = 1
Shell_m_VetAZ = arr
End Function
Function CreaVetUnivoco(Rng As Excel.Range) As Variant
Dim NoDupes As New Collection
Dim arr(), arr2(), v, temp
Dim index As Long ', d As Long, p As Long
Dim c As Long, Ncol As Long
Dim ultimo As Long, primo As Long
ReDim arr(Rng.Count - 1)
arr2 = Rng
On Error Resume Next
Set NoDupes = New Collection
ultimo = UBound(arr2)
primo = LBound(arr2)
For Ncol = 1 To UBound(arr2, 2)
For index = primo To ultimo
NoDupes.Add 0, CStr(arr2(index, Ncol))
If Err Then
Err.Clear
Else
temp = arr2(index, Ncol)
If Not IsEmpty(temp) Then 'istruzione per escludere gli empty
arr(c) = temp
r
"Maurizio Borrelli" ha scritto:
> Sarebbe opportuno spaziare entro limiti ben definiti. Io come limite mi
> pongo i limiti di Excel.
non sono molto daccordo ... già che ci siamo ... ti chiedo di leggere
attentamente queste righe sotto ...
sono due tecniche di lettura di garndi quantiotà di celle ... una quella
apostrofata l'hai usata qui sopra ... l'altra è una possibile alternativa un
po' più veloce ... che trasferisce i dati di un range in una matrice
se vuoi testarle e analizzarle ... mi piacerebbe sapere cosa ne pensi ...
ancora grazie
ciao
r
Sub test()
Dim rngin As Excel.Range, rng As Excel.Range
Dim rngRow As Excel.Range
Dim vntItem
Dim arr(), i As Long, a As Long
With Foglio1
With .Range("A1")
Set rngin = .Range(.Cells(1, 1) _
, .End(xlDown) _
).Resize(, 3)
End With
End With
'tuo codice ...
'For Each rngRow In rngin.Rows
' For Each rng In rngRow.Cells
' vntItem = rng.Value
' Next
'Next
'ci mette circa 1/4 del tempo
ReDim arr(rngin.Rows.Count - 1, rngin.Columns.Count - 1)
For i = 0 To rngin.Rows.Count - 1
For a = 0 To rngin.Columns.Count - 1
vntItem = arr(i, a)
Next a
Next i
'rngin = arr 'volendo riricaricare i valori nel range
'le modifiche al valore delle celle sarebbe molto più lento
End Sub
> > p.s.
> > la tua seconda non ordina e non riesco a capire perchè
>
> A me si'. E la terza?
la terza si :-)
r
"draleo" ha scritto:
> Fantastici entrambi. Sia la procedura di Maurizio (che ora, dopo le sue
> spiegazioni, funziona benissimo) che quella di “r” (che ora ha eliminato
> l’inconveniente della riga vuota sulla listbox) permettono di mettere in una
> listbox dati univoci e ordinati: oltre 50 mila voci trasformati in circa 200
> item ORDINATI in un semplice batter d’occhio: di gran lunga più veloci di
> tutti gli altri modi che conoscevo (molto pochi in verità). Ho imparato più
> studiando le vostre procedure che leggendo per un anno i sacri testi
> Vuol dire che (se non disturbo troppo) approfitterò ancora di questa miniera
> d’oro …
> Grazie ad entrambi
> draleo
questa la stampo e domani la mostro al mio capo :-) ...
e poi a mia moglie :-)
e nessuno si azzardi a dire che ... sono la stessa persona ... :-)
ciao
r
Maurizio Borrelli
news:CAE45CD2-ED97-4492...@microsoft.com:
> ecco la mia versione *definitiva* ...
[...]
> Sub CreaElencoUnivoco2()
[...]
Ciao r.
Direi che ci siamo! Ho dato qualche sistematina qua e la', verifica se
ho interpretato tutto correttamente e se non m'e' sfuggita qualche
castronata.
' modR - Standard Module
'
Option Explicit
Sub CreaElencoUnivoco2_01()
Const k = "a1:c65536"
Dim frm As UserForm1
Set frm = New UserForm1
frm.ListBox1.List _
= Shell_m_VetAZ(CreaVetUnivoco(Range(k)))
frm.Show
Set frm = Nothing
End Sub
Function Shell_m_VetAZ(arr As Variant) As Variant
Dim primo As Long
Dim ultimo As Long
Dim tot As Long
Dim metro As Long
Dim index As Long
Dim value As Variant
Dim index2 As Long
primo = LBound(arr)
ultimo = UBound(arr)
tot = ultimo - primo + 1
Do
metro = metro * 3 + 1
Loop Until metro > tot
Do
metro = metro / 3
For index = metro + primo To ultimo
value = arr(index)
index2 = index
Do While (arr(index2 - metro) > value) Xor False
arr(index2) = arr(index2 - metro)
index2 = index2 - metro
If index2 - metro < primo Then Exit Do
Loop
arr(index2) = value
Next
Loop Until metro = 1
Shell_m_VetAZ = arr
End Function
Function CreaVetUnivoco(rng As Excel.Range) As Variant
Dim NoDupes As VBA.Collection
Dim arr2
Dim Ncol As Long
Dim primo As Long
Dim ultimo As Long
Dim index As Long
Dim c As Long
Dim temp
ReDim arr(1 To rng.Count)
arr2 = rng
Set NoDupes = New VBA.Collection
primo = LBound(arr2, 1)
ultimo = UBound(arr2, 1)
For Ncol = LBound(arr2, 2) To UBound(arr2, 2)
For index = primo To ultimo
On Error Resume Next
NoDupes.Add 0, CStr(arr2(index, Ncol))
If Err Then
Err.Clear
Else
temp = arr2(index, Ncol)
If Not IsEmpty(temp) Then
c = c + 1
arr(c) = temp
End If
End If
On Error GoTo 0
Next
Next
ReDim Preserve arr(1 To c)
CreaVetUnivoco = arr
Set NoDupes = Nothing
End Function
Maurizio Borrelli
news:CAE45CD2-ED97-4492...@microsoft.com:
Ciao r.
> con l'algoritmo Shellsort permette di
> ottimizzare anche quando l'elenco è già parzialmente ordinato .... ho
> verificato che è di gran lunga più veloce del quicksort su vettori univoci
> come in questo caso ...
Mah... Se lo dici tu. Io non ho visto tutta questa differenza fra
QuickSort e ShellSort. Almeno col QuickSort di Wirth che uso io, del
quale ho indicato il link:
http://www.it-lang-vb.net/Archivio/FAQ/FAQ00061.HTM
Sono andato a riguardarlo e ho visto che e' una versione un po'
anzianotta. Appendo qui sotto quel che ho usato io per le prove di
questo 3D:
' Niklaus Wirth
' _Algoritmi + Strutture Dati = Programmi_
' Tecniche Nuove, Milano 1987.
' 2 ORDINAMENTI
' 2.2 Ordinamento di array
' 2.2.6 Ordinamento per partizione
'
Public Function WirthQuickSort( _
ByVal a As Variant _
) As Variant
Const PLEFT = 0
Const PRIGHT = 1
Dim s() As Long
Dim c As Long
Dim n As Long
Dim l As Long
Dim r As Long
Dim i As Long
Dim j As Long
Dim v As Variant
Dim d As Variant
c = 1
n = ((UBound(a) - LBound(a)) \ 6) + 1
If n > c Then
ReDim s(PLEFT To PRIGHT, c To n)
Else
ReDim s(PLEFT To PRIGHT, c To c)
End If
s(PLEFT, c) = LBound(a)
s(PRIGHT, c) = UBound(a)
Do
l = s(PLEFT, c)
r = s(PRIGHT, c)
c = c - 1
Do
i = l
j = r
v = a((l + r) \ 2)
Do
Do While a(i) < v
i = i + 1
Loop
Do While v < a(j)
j = j - 1
Loop
If i <= j Then
d = a(i)
a(i) = a(j)
a(j) = d
i = i + 1
j = j - 1
End If
Loop Until i > j
If (j - l) < (r - i) Then
If i < r Then
c = c + 1
s(PLEFT, c) = i
s(PRIGHT, c) = r
End If
r = j
Else
If (l < j) Then
c = c + 1
s(PLEFT, c) = l
s(PRIGHT, c) = j
End If
l = i
End If
Loop Until l >= r
Loop Until c = 0
WirthQuickSort = a
r
"Maurizio Borrelli" ha scritto:
grazie mille
domani mi ci dedico
ciao e buona notte a tutti
r
r
"Maurizio Borrelli" ha scritto:
> "r" wrote in message
> news:CAE45CD2-ED97-4492...@microsoft.com:
>
> > ecco la mia versione *definitiva* ...
> [...]
> > Sub CreaElencoUnivoco2()
> [...]
>
> Ciao r.
>
> Direi che ci siamo! Ho dato qualche sistematina qua e la', verifica se
> ho interpretato tutto correttamente e se non m'e' sfuggita qualche
> castronata.
quel direi che ci siamo ... lo stampo e lo appendo sul comodino :-)
> Set frm = New UserForm1
questa è una bella finezza ...
> frm.ListBox1.List _
ero convinto che list funzionasse solo con le parentesi
su questo dissento ... preferisco arr a base 0
> arr2 = rng
>
> Set NoDupes = New VBA.Collection
>
> primo = LBound(arr2, 1)
> ultimo = UBound(arr2, 1)
> For Ncol = LBound(arr2, 2) To UBound(arr2, 2)
> For index = primo To ultimo
>
> On Error Resume Next
giustamente la gestone degli errori va abbassata a questa posizione
> NoDupes.Add 0, CStr(arr2(index, Ncol))
> If Err Then
> Err.Clear
> Else
> temp = arr2(index, Ncol)
> If Not IsEmpty(temp) Then
> c = c + 1
> arr(c) = temp
> End If
> End If
> On Error GoTo 0
>
> Next
> Next
>
> ReDim Preserve arr(1 To c)
> CreaVetUnivoco = arr
>
> Set NoDupes = Nothing
> End Function
>
> --
> Maurizio Borrelli [Microsoft MVP - Excel]
> http://www.riolab.org/
un ultima notazione ... a elenco vuoto da errore ... (anche la mia)
grazie ancora
r
r
"Maurizio Borrelli" ha scritto:
questo algoritmo funziona alla grande
rivedo nuovamente le mie posizioni
adesso se riesco cerco di capire dove ho sbagliato
ancora grazie
r
Maurizio Borrelli
news:DF5F17E1-C2FE-4A76...@microsoft.com:
> "Maurizio Borrelli" ha scritto:
[...]
> > ReDim arr(1 To rng.Count)
> su questo dissento ... preferisco arr a base 0
Non e' questione di preferenze. Excel e' un ambiente (in massima parte)
a base 1 quindi trovo piu' comodo adeguarmi perche' rischio meno.
In generale la regola che seguo e': strutture in memoria, base zero.
strutture "record", base 1.
r
"Maurizio Borrelli" ha scritto:
una volta ho aggiunto option base 1 ...
ho fatto tanti di quei casini ... :-)
so che non è il caso in questione ...
come hai fatto te non crea problma alcuno naturalmente ...
ciao
r
Maurizio Borrelli
news:152313E3-9DDD-4B7D...@microsoft.com:
> "Maurizio Borrelli" ha scritto:
[...]
> > > > ReDim arr(1 To rng.Count)
> > > su questo dissento ... preferisco arr a base 0
> > Non e' questione di preferenze. Excel e' un ambiente (in massima parte)
> > a base 1 quindi trovo piu' comodo adeguarmi perche' rischio meno.
> > In generale la regola che seguo e': strutture in memoria, base zero.
> > strutture "record", base 1.
> una volta ho aggiunto option base 1 ...
> ho fatto tanti di quei casini ... :-)
> so che non è il caso in questione ...
> come hai fatto te non crea problma alcuno naturalmente ...
Ciao r.
Mi fa piacere che hai tirato fuori Option Base. Pericolosa come quasi
tutte le "Option".
Option Explicit. E' pericolosa quando manca.
Option Base e Option Compare. Mai e poi mai scrivere codice dipendente
da tali opzioni. Per fortuna in vb sono stati introdotti tutti gli
strumenti necessari per farne a meno.
Maurizio Borrelli
news:DF5F17E1-C2FE-4A76...@microsoft.com:
> "Maurizio Borrelli" ha scritto:
[...]
> un ultima notazione ... a elenco vuoto da errore ... (anche la mia)
Ciao r.
Non credo valga la pena "delegare" a quelle funzioni il compito di
valutare la coerenza dell'array che si passa loro. Tale valutazione si
puo' fare per esempio *prima* di invocarle. In linea di principio: a
ciascuna funzione il suo compito, il piu' possibile limitato e
perfettamente definito, da svolgere possibilmente alla perfezione, e le
sue responsabilita'.
r
"Maurizio Borrelli" ha scritto:
> "r" wrote in message
> news:DF5F17E1-C2FE-4A76...@microsoft.com:
> > "Maurizio Borrelli" ha scritto:
>
> [...]
> > un ultima notazione ... a elenco vuoto da errore ... (anche la mia)
>
> Ciao r.
>
> Non credo valga la pena "delegare" a quelle funzioni il compito di
> valutare la coerenza dell'array che si passa loro. Tale valutazione si
> puo' fare per esempio *prima* di invocarle.
sono daccordo.
r