trovare indice array

[albatros54Moderatore albatros54 Karma: 89 pts]

il file di riferimento è quello del #35570

Sub AssQuartiereAlbatrosbis()
    Dim conta As Integer, contabis As Integer, a As Integer
    Dim rngana As Range, rngstra As Range
    Dim arr1(), arr2()
    Dim ce As Variant
    Dim s As String
    Dim f As Object
    conta = Application.WorksheetFunction.CountA(Sheets("anagrafico").Range("E:E"))
    contabis = Application.WorksheetFunction.CountA(Sheets("stradario").Range("a:a"))
    With Worksheets("anagrafico")
        Set rngana = .Range("E2:E" & conta)
        arr1 = Application.Transpose(rngana)
    End With
    With Worksheets("stradario")
        Set rngstra = .Range("a2:b" & contabis)
        arr2 = Application.Transpose(rngstra)
    End With
    For a = 1 To UBound(arr1)
        For Each ce In arr1
            s = Trim(ce)
            Set f = Worksheets("anagrafico").Range("E:E").Find(s, LookIn:=xlValues, lookat:=xlPart)
            If Not f Is Nothing Then f.Offset(, 1) = arr1(a, 2)
        Next
    Next

    MsgBox "Fatto"
End Sub

vorrei trovare il cassetto nella arr2(1) del valore ritornato dalla variabile "s" e farmi ritornare il valore dello stesso cassetto nella arr2(2).

Spero di essere stato chiaro, forse.

 

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[scossaPartecipante scossa Karma: 37 pts]

Ciao Albatros,

Chiaro mica tanto: cos'è il codice che hai postato? non c'è nessun riferimento a arr2.

P.S.C'è un errore nella riga:

If Not f Is Nothing Then f.Offset(, 1) = arr1(a, 2)If Not f Is Nothing Then f.Offset(, 1) = arr1(a, 2)

visto che arr1 ha una sola dimensione.

[albatros54Moderatore albatros54 Karma: 89 pts]

Ciao
effettivamente sono stato molto poco chiaro,lo scenario è quello del file postato #35570.
L'OP si trova in queste condizioni " ho un file excel con diversi fogli, nel foglio "anagrafico" nella colonna "E" ho degli indirizzi delle vie, nel foglio "stradario" ho nella colonna "A" le vie, che in parte corrispondono alla colonna "E" del foglio "anagrafico", mentre nella colonna "B" , sempre del foglio "stradario", ho i rioni che corrispondono alle vie della colonna "A".
Vorrei fare in modo che nel foglio "anagrafico" in corrispondenza della via della colonna"E" mi venga messo , nella colonna "F" ,il rione pescato nel foglio"stradario."
Codice postato da vecchio frac, che funziona.

Sub AssQuartiere()
Dim ce As Range
Dim f As Range
Dim s As String
Dim ra As Range

    With Worksheets("stradario")
        Set ra = .Range("A2:A" & .Range("A2").End(xlDown).Row)
    End With
    
    For Each ce In ra
        s = Trim(ce)
        Set f = Worksheets("anagrafico").Range("F:F").Find(s, LookIn:=xlValues, lookat:=xlPart)
        If Not f Is Nothing Then f.Offset(, 1) = s
    Next
    
    MsgBox "Fatto"
End Sub

Codice postato da albatros54, che funziona

Sub AssQuartiereAlbatros()
    Dim strada As String, sToken As String, sret As String
    Dim j As Integer, conta As Integer
    Dim cerca As Object
    Dim rng As Range
    Dim cl As Range
    conta = Application.WorksheetFunction.CountA(Sheets("anagrafico").Range("E:E"))
    contabis = Application.WorksheetFunction.CountA(Sheets("stradario").Range("a:a"))
    Set rng = Sheets("anagrafico").Range("E2:E" & conta)
    For Each cl In rng
        cl = LCase(cl)
        For j = 1 To Len(cl)
            sToken = Mid(cl, j, 1)
            If Not IsNumeric(sToken) Then
                sret = LCase(sret & sToken)
            Else
                Exit For
            End If
        Next


        Set cerca = Sheets("stradario").Range("A2:A" & contabis).Find(Trim(sret))
        'cerca = LCase(cerca)
        If cerca Is Nothing Then
            'MsgBox "non esiste"
        Else
            'MsgBox cerca.Address
            Sheets("anagrafico").Range(cl.Address).Offset(0, 1) = cerca.Offset(0, 1)
        End If
        sret = ""
    Next
End Sub

pero sia il codice di vecchio frac che quello di albatros54, doto che i dati da spazzolare sono piu di 6000, sono molto lenti.
Per cercare di velocizzare, non so fino a che punto,vorrei lavorare con le matrici, quindi ho crearo una matrice "arr1" che corrisponde hai dati della colonna "E" foglio"anagrafico", monodimensione, poi ho creato una "arr2" che corrisponde hai dati del foglio "stradario" range"A:B", bidimesione.

Sub AssQuartiereAlbatrosbis()
    Dim conta As Integer, contabis As Integer, a As Integer
    Dim rngana As Range, rngstra As Range
    Dim arr1(), arr2()
    Dim ce As Variant
    Dim s As String
    Dim f As Object
    conta = Application.WorksheetFunction.CountA(Sheets("anagrafico").Range("E:E"))
    contabis = Application.WorksheetFunction.CountA(Sheets("stradario").Range("a:a"))
    With Worksheets("anagrafico")
        Set rngana = .Range("E2:E" & conta)
        arr1 = Application.Transpose(rngana)
    End With
    With Worksheets("stradario")
        Set rngstra = .Range("a2:b" & contabis)
        arr2 = Application.Transpose(rngstra)
    End With
    For a = 1 To UBound(arr1)
        For Each ce In arr1
           s = LCase(Trim(ce))
'            Set f = Worksheets("anagrafico").Range("E:E").Find(s, LookIn:=xlValues, lookat:=xlPart)
'            If Not f Is Nothing Then f.Offset(, 1) = arr1(a, 2)
'        Next
For j = LBound(arr2, 2) To UBound(arr2, 2)
        For i = LBound(arr2, 1) To UBound(arr2, 1)
        If arr2(i, j) = s Then
        MsgBox arr2(2, j)
        
            MsgBox arr2(i, j)
            End If
        Next i
    Next j
    Next
    Next

    MsgBox "Fatto"
End Sub

Vorrei spazzolare la "arr1" per ogni elemento, cercare questo elemento nella "arr2", e una volta trovato ritornarmi il valore corrispondente alla "arr2",della seconda dimensione.
Non so se è fattibile.
spero di essere stato chiaro
albatros54

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

albatros54 ha scritto:

doto che i dati da spazzolare sono piu di 6000, sono molto lenti.

Un suggerimento valido è quello di disabilitare l'aggiornamento dello schermo e di disabilitare l'esecuzione delle macro e di disabilitare il calcolo automatico, da ripristinare al termine. Secondo me si velocizza un pochino il tutto. Poi ci possono essere mille altre soluzioni.

Una applicazione di questo metodo prevede una sub pubblica da richiamare rispettivamente con app_enable False all'inizio e con app_enable True al termine dell'esecuzione della procedura.

Public Sub app_enable(mode As Boolean)
'abilita o disabilita eventi, cursore, ricalcolo e refresh pagina
    With Application
        .ScreenUpdating = mode
        .Cursor = IIf(mode, xlDefault, xlWait)
        .EnableEvents = mode
        .Calculation = IIf(mode, xlCalculationAutomatic, xlCalculationManual)
    End With
End Sub

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

albatros54 ha scritto:

Vorrei spazzolare la "arr1" per ogni elemento

Per quanto siano più performanti gli array (e ti do ragione) rispetto agli oggetti Range, il problema è sempre che si tratta di fare una ricerca e comparazione di stringhe, il che sembra essere molto inefficiente in VBA. Inoltre penso che sarebbe meglio appiattire gli array per renderli monodimensionali e lavorare quindi su un indice solo (stavo guardando LBound(arr2, 2)). Un altro consiglio valido è quello di assegnare a variabili gli indici estremi del ciclo For j = LBound(arr2, 2) To UBound(arr2, 2) (e anche di quello successivo) invece che fargli calcolare ad ogni passaggio LBound(arr2, 2) e UBound(arr2, 2).

[albatros54Moderatore albatros54 Karma: 89 pts]

Volevo cercare di aumentare la perfomace  e velocizzare il codice, ma forse è meglio lasciare il tutto cosi com'è  

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

albatros54 ha scritto:

doto che i dati da spazzolare sono piu di 6000, sono molto lenti.

Comunque ho fatto per curiosità un paio di test con circa diecimila righe riempite  a caso.

Senza disabilitare niente il mio codice ha impiegato cinque secondi e rotti per la prima esecuzione, meno di un secondo per la seconda esecuzione (tra parentesi, nel mio codice c'è un errorino :D, ripropongo qui una versione migliorata e corretta).

Option Explicit

Sub AssQuartiere2()
Dim ce As Range
Dim f As Range
Dim s As String
Dim z As String
Dim ra As Range

    Debug.Print Timer

    With Worksheets("toponomastica")
        Set ra = .Range("A2:A" & .Range("A2").End(xlDown).Row)
    End With
    
    For Each ce In ra
        s = Trim(ce)
        z = Trim(ce.Offset(, 1))
        Set f = Worksheets("pazienti").Range("F:F").Find(s, LookIn:=xlValues, lookat:=xlPart)
        If Not f Is Nothing Then f.Offset(, 1) = z
    Next
    
    Debug.Print Timer
    
    MsgBox "Fatto"
End Sub

 

[albatros54Moderatore albatros54 Karma: 89 pts]

vecchio frac ha scritto:

tra parentesi, nel mio codice c'è un errorino :D,

credo di aver trovato l'errorino, corretto, effettivamente il codice prova sul file dell'OP è piu veloce.

`Sub AssQuartiere2()
Dim ce As Range
Dim f As Object
Dim s As String
Dim z As String
Dim ra As Range

    Debug.Print Timer

    With Worksheets("stradario")
        Set ra = .Range("A2:A" & .Range("A2").End(xlDown).Row)
    End With
    
    For Each ce In ra
        s = Trim(ce)
        z = Trim(ce.Offset(, 1))
        Set f = Worksheets("anagrafico").Range("E:E").Find(s, LookIn:=xlValues, lookat:=xlPart)
        If Not f Is Nothing Then Sheets("anagrafico").Range(f.Address).Offset(0, 1) = z
    Next
    
    Debug.Print Timer
    
    MsgBox "Fatto"
End Sub
`

 nella finestra di debug ho

55876,58
56054,67

da capire i valori

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Quasi tre minuti? E' un tempo altissimo!
Io invece ho lanciato la tua macro ma non riesco ad arrivare in fondo, si inchioda e mi tocca eliminare il processo da Gestione attività 🙁

[albatros54Moderatore albatros54 Karma: 89 pts]

vecchio frac ha scritto:

Io invece ho lanciato la tua macro

quale?

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Il secondo codice da te postato, "AssQuartiereAlbatrosbis".
Dici che ho sbagliato qualcosa?

[albatros54Moderatore albatros54 Karma: 89 pts]

non credo, sicuramente è da rivedere.

 

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Albatros, non per sfiducia verso di te ma per sfida personale ho rivisto il tuo codice. Ecco la mia revisione (sul mio pc ci mette 1,175 secondi con il file che hai citato, che nell'anagrafico ha 1263 nomi):

Sub AssQuartiereAlbatrosbis()
    Dim conta As Integer, contabis As Integer
    Dim arr1(), arr2(), arr3()
    Dim k As Long
    Dim h As Long
    Dim i As Integer
    Dim j As Integer
    Dim t1 As Single, t2 As Single
    
    t1 = Timer
    conta = Application.WorksheetFunction.CountA(Sheets("anagrafico").Range("E:E"))
    contabis = Application.WorksheetFunction.CountA(Sheets("stradario").Range("a:a"))
    With Worksheets("anagrafico")
        arr1 = Application.Transpose(.Range("E2:E" & conta))
    End With
    With Worksheets("stradario")
        arr2 = Application.Transpose(.Range("a2:a" & contabis))
    End With
    With Worksheets("stradario")
        arr3 = Application.Transpose(.Range("b2:b" & contabis))
    End With
    
    h = UBound(arr1)
    k = UBound(arr2)
    
    For i = 1 To k
        For j = 1 To h
            If arr1(j) Like arr2(i) & "*" Then
                Debug.Print arr2(i), "-->", arr3(i)
            End If
        Next
    Next

    t2 = Timer
    MsgBox "Fatto in " & t2 - t1 & " secondi."
End Sub

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Ci sono nel file delle righe vuote che vanno eliminate per permettere una miglior esecuzione. Così facendo mi sono accorto che le righe da elaborare sono 5338 🙂

Ho apportato una modifica al codice nella parte clou dell'elaborazione (non cambia il concetto che ne sta alla base), in questo modo visualizzo in Immediata solo le righe che hanno una corrispondenza via/quartiere; con il file postato ci metto poco meno di cinque secondi:

    For j = 1 To h
        Debug.Print arr1(j), ;
        For i = 1 To k
            If arr1(j) Like arr2(i) & "*" Then
                Debug.Print "-->", arr3(i)
            End If
        Next
        Debug.Print
    Next

 

[albatros54Moderatore albatros54 Karma: 89 pts]

Si OK il codice è velocissimo , pero non abbiamo raggiunto lo scopo, quello di trasferire i dati nella colonna F del foglio.

 

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

No, il mio codice non lo fa, però il valore è in arr3(i) e la modifica è semplice. Io volevo solo verificare che in effetti lavorare con gli array è comunque performante. Ho dovuto aggiungere il terzo array che tiene traccia della seconda colonna del range in foglio stradario, perché così riesco ad appiattire il secondo array e di conseguenza non ho bisogno di testarne gli indici superiori.

    For j = 1 To h
        For i = 1 To k
            If arr1(j) Like arr2(i) & "*" Then
                Cells(j, "F") = arr3(i)
            End If
        Next
        Debug.Print
    Next

Il collo di bottiglia è naturalmente il Like perché sulla mia macchina ci mette 176 secondi (quasi tre minuti) in prima esecuzione, e addirittura 225 secondi in seconda esecuzione, e 210 in terza (con ScreenUpdating impostato a False).

Si deve quindi migliorare la parte del confronto di stringhe, magari con un'API. O con un trucco alla scossa 😀

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Ma sarò un pirlotto? 😀

Bisogna togliere quel "Debug.Print" naturalmente! Allora l'esecuzione scende sensibilmente: meno di un secondo se disabilito il ricalcolo automatico.

[Autore]

Articoli