Pannello di Controllo Moderatore ]

Ordinamento senza duplicati con bubblesort

Creare una macro - Scrivere uno script - Usare le API

Ordinamento senza duplicati con bubblesort

Messaggioda patel » venerdì 15 marzo 2019, 20:35

In colonna A ho una serie di stringhe che vorrei ordinare con bubblesort eliminando anche i duplicati, prendendo spunto dalla macro di Gaetano per Chimico, ho scritto questa che funziona. Vorrei sapere se è possibile utilizzare un solo array (lista), magari bidimensionale per l'utilizzo di SetDataArray.
Codice: Seleziona tutto   Espandi visualeStringi visuale
Sub ordina 'bubblesort
Set Dic = CreateObject("Scripting.Dictionary")
REM Si carica la libreria Tools per accedere alla funzione BubbleSortList   
If (Not GlobalScope.BasicLibraries.isLibraryLoaded("Tools")) Then
    GlobalScope.BasicLibraries.LoadLibrary("Tools")
End if 
sh = thiscomponent.Sheets(0)
r= 2
do 
  v = sh.GetCellRangeByName("A" & r).String
  if v = "" then exit do
  If Dic.Exists(v) = False Then
     Dic.Add v, 0
  end if
  r= r + 1
Loop
iF Dic.count > 0 Then
   n = Dic.count-1
   Redim lista(0 To n)
   For i = 0 To n
      lista(i) = Dic.Keys()(i)
   Next i
   lista() = BubbleSortList(lista)
   Dim arr(1 to n+1, 1 To 1) ' <<<< da evitare
   For i = 0 To n
      arr(i+1, 1) = lista(i)
   Next i
   CellRange = Sh.getCellRangeByName("C1:C" & n+1)
   CellRange.SetDataArray(arr)
end if
End sub
-------------------
OpenOffice 4.1 e Libre Office 6.o.7.3 su Windows 10
allega un file di esempio, guadagnerai tempo tu e lo farai risparmiare a chi ti aiuta
patel
Volontario attivo
Volontario attivo
 
Messaggi: 3153
Iscritto il: venerdì 30 aprile 2010, 8:04
Località: Livorno

Re: Ordinamento senza duplicati con bubblesort

Messaggioda Gaetanopr » sabato 16 marzo 2019, 10:59

Codice: Seleziona tutto   Espandi visualeStringi visuale
Sub ordina 'bubblesort
Set Dic = CreateObject("Scripting.Dictionary")
REM Si carica la libreria Tools per accedere alla funzione BubbleSortList   
If (Not GlobalScope.BasicLibraries.isLibraryLoaded("Tools")) Then
    GlobalScope.BasicLibraries.LoadLibrary("Tools")
End if 
sh = thiscomponent.Sheets(0)
r= 2
do 
  v = sh.GetCellRangeByName("A" & r).String
  if v = "" then exit do
  If Dic.Exists(v) = False Then
     Dic.Add v, 0
  end if
  r= r + 1
Loop
iF Dic.count > 0 Then
   n = Dic.count-1
   Redim lista(0 To n, 0)
   For i = 0 To n
      lista(i, 0) = Dic.Keys()(i)
   Next i
   lista = BubbleSortList(lista())
   CellRange = Sh.getCellRangeByName("C1:C" & n+1)
   CellRange.SetDataArray(lista)
end if
End Sub


Hai notato che mette la "q" prima della "p" ?
Openoffice 4.1 su windows xp
Gaetanopr
Volontario
Volontario
 
Messaggi: 2559
Iscritto il: mercoledì 21 novembre 2012, 21:07

Re: Ordinamento senza duplicati con bubblesort

Messaggioda patel » sabato 16 marzo 2019, 11:45

grazie Gaetano, non avevo fatto caso al q, però ho notato che dipende dalla disposizione delle lettere, se sono presenti a e b non accade
-------------------
OpenOffice 4.1 e Libre Office 6.o.7.3 su Windows 10
allega un file di esempio, guadagnerai tempo tu e lo farai risparmiare a chi ti aiuta
patel
Volontario attivo
Volontario attivo
 
Messaggi: 3153
Iscritto il: venerdì 30 aprile 2010, 8:04
Località: Livorno

Re: Ordinamento senza duplicati con bubblesort

Messaggioda Gaetanopr » sabato 16 marzo 2019, 19:06

Bubblesort presenta qualche pecca non è affidabile.
Openoffice 4.1 su windows xp
Gaetanopr
Volontario
Volontario
 
Messaggi: 2559
Iscritto il: mercoledì 21 novembre 2012, 21:07

Re: Ordinamento senza duplicati con bubblesort

Messaggioda patel » domenica 17 marzo 2019, 10:12

Temo funzioni soltanto con valori numerici
-------------------
OpenOffice 4.1 e Libre Office 6.o.7.3 su Windows 10
allega un file di esempio, guadagnerai tempo tu e lo farai risparmiare a chi ti aiuta
patel
Volontario attivo
Volontario attivo
 
Messaggi: 3153
Iscritto il: venerdì 30 aprile 2010, 8:04
Località: Livorno

Re: Ordinamento senza duplicati con bubblesort

Messaggioda Gaetanopr » domenica 17 marzo 2019, 13:32

Il problema è che presenta alcuni bug ho letto, se l'ordinamento lo "ripassi" la p la riordina ma non è una soluzione efficiente, bisognerebbe provare con altri algoritmi.
Codice: Seleziona tutto   Espandi visualeStringi visuale
lista = BubbleSortList(lista())
   lista = BubbleSortList(lista())
Openoffice 4.1 su windows xp
Gaetanopr
Volontario
Volontario
 
Messaggi: 2559
Iscritto il: mercoledì 21 novembre 2012, 21:07

Re: Ordinamento senza duplicati con bubblesort

Messaggioda patel » domenica 17 marzo 2019, 13:52

ho provato con quicksort e funziona
Codice: Seleziona tutto   Espandi visualeStringi visuale
Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long

  tmpLow = inLow
  tmpHi = inHi

  pivot = vArray((inLow + inHi) \ 2)

  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend

     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend

     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend

  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

Sub ordinaquick 'funziona
Set Dic = CreateObject("Scripting.Dictionary")
REM Si carica la libreria Tools per accedere alla funzione BubbleSortList   

sh = thiscomponent.Sheets(0)
r= 2
do 
  v = sh.GetCellRangeByName("A" & r).String
  if v = "" then exit do
  If Dic.Exists(v) = False Then
     Dic.Add v, 0
  end if
  r= r + 1
Loop
Matrice = ""
iF Dic.count > 0 Then
   n = Dic.count-1
   Redim lista(0 To n)
   For i = 0 To n
      lista(i) = Dic.Keys()(i)
   Next i
   Call QuickSort(lista, 0, UBound(lista))
   Matrice = Join(lista, " ")
   sh.GetCellRangeByName("B1").String = matrice
   Dim arr(1 to n+1, 1 To 1)
   For i = 0 To n
      arr(i+1, 1) = lista(i)
   Next i
   CellRange = Sh.getCellRangeByName("C1:C" & n+1)
   CellRange.SetDataArray(arr)
end if
End sub
-------------------
OpenOffice 4.1 e Libre Office 6.o.7.3 su Windows 10
allega un file di esempio, guadagnerai tempo tu e lo farai risparmiare a chi ti aiuta
patel
Volontario attivo
Volontario attivo
 
Messaggi: 3153
Iscritto il: venerdì 30 aprile 2010, 8:04
Località: Livorno

Re: Ordinamento senza duplicati con bubblesort

Messaggioda Gaetanopr » domenica 17 marzo 2019, 14:00

Pure io avevo provato ma mi dava un errore, adesso riprovo
Openoffice 4.1 su windows xp
Gaetanopr
Volontario
Volontario
 
Messaggi: 2559
Iscritto il: mercoledì 21 novembre 2012, 21:07

Re: Ordinamento senza duplicati con bubblesort

Messaggioda Gaetanopr » lunedì 18 marzo 2019, 12:41

patel ha scritto:ho provato con quicksort e funziona

Si ma usando due array, all'inizio chiedevi di usarne solo 1.
Prova in questo modo, all'inizio mi dava un errore, veniva fuori un valore nullo, ora ho apportato una modifica al setdataarray e funziona(facendolo dentro la sub del quicksort)
Codice: Seleziona tutto   Espandi visualeStringi visuale
Sub ordina
Set Dic = CreateObject("Scripting.Dictionary")
REM Si carica la libreria Tools per accedere alla funzione BubbleSortList   
If (Not GlobalScope.BasicLibraries.isLibraryLoaded("Tools")) Then
    GlobalScope.BasicLibraries.LoadLibrary("Tools")
End if 
sh = thiscomponent.Sheets(0)
r= 2
do 
  v = sh.GetCellRangeByName("A" & r).String
  if v = "" then exit do
  If Dic.Exists(v) = False Then
     Dic.Add v, 0
  end if
  r= r + 1
Loop
iF Dic.count > 0 Then
   n = Dic.count-1
   Redim lista(0 To n, 0)
   For i = 0 To n
      lista(i, 0) = Dic.Keys()(i)
   Next i
   QuickSort(lista())
'  CellRange = Sh.getCellRangeByName("C1:C" & n+1)
'  CellRange.SetDataArray(lista)
end if
End Sub

Sub QuickSort( a(), optional p As long, optional u As long )  as variant
Dim i As long, j As long, m, t
   
    p = iif(IsMissing( p ), lBound(a), p )
    u = iif(IsMissing( u ), uBound(a), u )
   
    i = p
    j = u
    m = a((p + u) / 2)
   
    While (i <= j)
      While (a(i) < m And i < u) : i = i + 1 : Wend
      While (m < a (j) And j> p) : j = j - 1 : Wend

      If (i <= j) Then
        t = a(i)
        a(i) = a(j)
        a(j) = t
        i = i + 1 :    j = j - 1
      End If
    Wend

    If (p < j) Then QuickSort(a, p, j)
    If (i < u) Then QuickSort(a, i, u)
 
    CellRange = ThisComponent.Sheets(0).getCellRangeByName("C1:C"&Ubound(a)+1)
    CellRange.SetDataArray(a)
End Sub
Openoffice 4.1 su windows xp
Gaetanopr
Volontario
Volontario
 
Messaggi: 2559
Iscritto il: mercoledì 21 novembre 2012, 21:07

Re: Ordinamento senza duplicati con bubblesort

Messaggioda patel » lunedì 18 marzo 2019, 13:45

oppure trasformando la sub in function
Codice: Seleziona tutto   Espandi visualeStringi visuale
Sub ordina
Set Dic = CreateObject("Scripting.Dictionary")
sh = thiscomponent.Sheets(0)
r= 2
do
  v = sh.GetCellRangeByName("A" & r).String
  if v = "" then exit do
  If Dic.Exists(v) = False Then
     Dic.Add v, 0
  end if
  r= r + 1
Loop
iF Dic.count > 0 Then
   n = Dic.count-1
   Redim lista(0 To n, 0)
   For i = 0 To n
      lista(i, 0) = Dic.Keys()(i)
   Next i
   lista = QuickSort(lista())
    CellRange = Sh.getCellRangeByName("C1:C"&Ubound(lista)+1)
    CellRange.SetDataArray(lista)
end if
End Sub

Function QuickSort( a(), optional p As long, optional u As long )  as variant
Dim i As long, j As long, m, t
   
    p = iif(IsMissing( p ), lBound(a), p )
    u = iif(IsMissing( u ), uBound(a), u )
   
    i = p
    j = u
    m = a((p + u) / 2)
   
    While (i <= j)
      While (a(i) < m And i < u) : i = i + 1 : Wend
      While (m < a (j) And j> p) : j = j - 1 : Wend

      If (i <= j) Then
        t = a(i)
        a(i) = a(j)
        a(j) = t
        i = i + 1 :    j = j - 1
      End If
    Wend
    If (p < j) Then QuickSort(a, p, j)
    If (i < u) Then QuickSort(a, i, u)
   QuickSort =  a
End Function
Ultima modifica di patel il lunedì 18 marzo 2019, 13:50, modificato 1 volta in totale.
-------------------
OpenOffice 4.1 e Libre Office 6.o.7.3 su Windows 10
allega un file di esempio, guadagnerai tempo tu e lo farai risparmiare a chi ti aiuta
patel
Volontario attivo
Volontario attivo
 
Messaggi: 3153
Iscritto il: venerdì 30 aprile 2010, 8:04
Località: Livorno

Re: Ordinamento senza duplicati con bubblesort

Messaggioda Gaetanopr » lunedì 18 marzo 2019, 13:49

Si, pure in questo modo, credo possiamo chiuderla :super:
Openoffice 4.1 su windows xp
Gaetanopr
Volontario
Volontario
 
Messaggi: 2559
Iscritto il: mercoledì 21 novembre 2012, 21:07


Torna a Macro e UNO API

Chi c’è in linea

Visitano il forum: Nessuno e 2 ospiti