contare dati su celle alternate

[mauri27Partecipante mauri27]

ciao, ho un problema che non riesco a svolgere e cioe' che dovrei contare per un certo numero il valore associato ma con celle alternate, con formula ci sono riuscito ma essendo il database esteso excel non mi permette oltre 8.194 dati per cui avrei bisogno della vba ma non ne sono capace, qualcuno puo' aiutarmi? grazie

Allego file , dove nel foglio "valore x numero" vorrei trovare per ogni numero nella colonna da A2 a A40 a righe alternate i numeri da 1 a 20 per ogni valore indicato nella riga da B1 a cella U1, associando i numeri nel foglio "cavoli miei" dalla cella I2 a celle alternate perchè nella cella vicina (j2)c'è il valore. esempio n.1 per il valore 0 = 9 (il conteggio è stato fatto manualmente). 

Attenzione, pero' , perchè per i numeri che esistono in tutte le colonne e cio' il 1,5,10 e 20 viene contato doppio.

dimenticavo che il database inizia con la colonna I e termina con la colonna ZY o ZZ 

un plauso per chi ci riesce. Mi servirebbe il codice vba completo e pronto da inserire nel modulo che mi indicherete, grazie ancora! 

Allegati:

You must be logged in to view attached files.

[alexps81Moderatore alexps81 Karma: 58 pts]

Non ho capito assolutamente nulla della spiegazione. Puoi essere più chiaro e magari riporti un esempio pratico?

 

EDIT: Forse ho capito, faccio un esempio pratico: il numero 6 presente in U2 è il risultato del fatto che 300.000,00 (che è scritto in U1) è presente 6 volte nel foglio "cavoli miei" con numero 1 a fianco alla sua sinistra

[alexps81Moderatore alexps81 Karma: 58 pts]

Allora vediamo se ho capito bene. Prova a cancellare tutti i dati da B2 a U40 nel Foglio "valore x numero", poi prova questa macro:

Option Explicit

Sub estraiDati()
    Dim wsValore As Worksheet, wsCavoli As Worksheet
    Dim r As Long, c As Long, ur As Long, lastCol As Long, j As Long
    Dim valore As Double, numero As Integer
    Dim arrList As Object
    Dim rng As Range, numTrovato As Range
    Dim firstAddress As String
    Dim coll As New Collection
    Dim k As Variant, rigoNumero As Variant
    
    On Error GoTo GestError
    
    Set wsValore = ThisWorkbook.Worksheets("valore x numero")
    Set wsCavoli = ThisWorkbook.Worksheets("cavoli miei")
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    wsValore.Range("B2:U40").ClearContents
    
    For r = 2 To 40 Step 2
        numero = wsValore.Cells(r, 1)
        coll.Add numero
    Next r

    ur = wsCavoli.Cells(Rows.Count, "I").End(xlUp).Row
    lastCol = wsCavoli.Cells(1, wsCavoli.Columns.Count).End(xlToLeft).Column
    For Each k In coll
        numero = k
        Set arrList = CreateObject("System.Collections.ArrayList")
        For j = 9 To lastCol Step 2
            Set rng = wsCavoli.Range(wsCavoli.Cells(2, j), wsCavoli.Cells(ur, j))
            Set numTrovato = rng.Find(What:=numero, LookIn:=xlValues, LookAt:=xlWhole)
            If Not numTrovato Is Nothing Then
            
                firstAddress = numTrovato.Address
                Do
                    valore = numTrovato.Offset(, 1).Value                    
                    arrList.Add valore                    
                Set numTrovato = rng.FindNext(numTrovato)
                Loop While Not numTrovato Is Nothing And firstAddress <> numTrovato.Address
            End If
        Next j
        
        If arrList.Count > 0 Then
            arrList.Sort
        
            rigoNumero = Application.Match(numero, wsValore.Range("A:A"), 0)
            If Not IsError(rigoNumero) Then
                For c = 2 To 21
                    For r = 0 To arrList.Count - 1
                        If Val(wsValore.Cells(1, c).Value) = arrList(r) Then
                            wsValore.Cells(rigoNumero, c).Value = wsValore.Cells(rigoNumero, c).Value + 1
                        End If
                    Next r
                Next c
            End If
        End If
        Set arrList = Nothing
    Next k

safetyExit:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    Set wsValore = Nothing
    Set wsCavoli = Nothing
    Set coll = Nothing
    Set rng = Nothing
    Set numTrovato = Nothing
    
    MsgBox "Fatto!", vbInformation
    Exit Sub

GestError:
    MsgBox "Errore nr: " & Err.Number & " - " & Err.Description, vbCritical
    Resume safetyExit
End Sub

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

alexps81 ha scritto:

è presente 6 volte nel foglio "cavoli miei"

Ho scaricato il file per rendermi conto che veramente il foglio si chiama davvero cosi'     

[alexps81Moderatore alexps81 Karma: 58 pts]

vecchio frac ha scritto:

Ho scaricato il file per rendermi conto che veramente il foglio si chiama davvero cosi'     

[mauri27Partecipante mauri27]

si perfetto

[mauri27Partecipante mauri27]

Scusa la mia ignoranza in vba. la devo salvare su quale foglio? è possibile farla partire automaticamente? grazie

 

[alexps81Moderatore alexps81 Karma: 58 pts]

mauri27 ha scritto:

la devo salvare su quale foglio?

Non in Foglio ma in un Modulo Standard. Vai in Sviluppo -->Visual Basic --> Inserisci --> Modulo. In questo Modulo ci incolli tutto questo codice.

mauri27 ha scritto:

è possibile farla partire automaticamente?

Cosa intendi con automaticamente? Immagino alla pressione di un pulsante? Se così fosse...disegna o una Forma (rettangolo) o un Controllo Modulo (Sviluppo --> Inserisci --> Pulsante (controllo modulo))

Nel primo caso, dopo aver disegnato la Forma, fai click con il tasto destro del mouse sulla Forma e scegli Assegna Macro. A quel punto scegli la Maro estraiDati()

Nel secondo caso, dopo aver disegnato il Pulsante (controllo modulo), in automatico si aprirà l'elenco delle macro da associare.

[mauri27Partecipante mauri27]

ti ringrazio di quanto fatto ma purtroppo ho provato la macro e mi dice errore di automazione. ho cambiato anche il nome del foglio correggendolo sulla macro che mi hai inviato.

[alexps81Moderatore alexps81 Karma: 58 pts]

Pubblica di nuovo il file con il tentativo che hai fatto 

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Sono pronto a scommettere che il problema sta nell'oggetto ArrayList che non e' disponibile sul pc in uso.

[alexps81Moderatore alexps81 Karma: 58 pts]

vecchio frac ha scritto:

il problema sta nell'oggetto ArrayList che non e' disponibile sul pc in uso

Può essere....magari si potrà sostituire con una Collection o una Dictionary. L'ArrayList era comoda perché ha il metodo Sort incluso   

[alexps81Moderatore alexps81 Karma: 58 pts]

Ciao @mauri27

proviamo a vedere se @VecchioFrac ha ragione (ma non ho dubbi   ). Utilizza questo codice aggiornato, che fa uso di una Collection (collValori) al posto dell'ArrayList (arrList):

Option Explicit

Sub estraiDati()
    Dim wsValore As Worksheet, wsCavoli As Worksheet
    Dim r As Long, c As Long, ur As Long, lastCol As Long, j As Long
    Dim valore As Double, numero As Integer
    Dim rng As Range, numTrovato As Range
    Dim firstAddress As String
    Dim coll As New Collection, collValori As Collection
    Dim k As Variant, rigoNumero As Variant, arrValori() As Variant, tempArray As Variant
    
    On Error GoTo GestError
    
    Set wsValore = ThisWorkbook.Worksheets("valore x numero")
    Set wsCavoli = ThisWorkbook.Worksheets("cavoli miei")
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    wsValore.Range("B2:U40").ClearContents
    
    For r = 2 To 40 Step 2
        numero = wsValore.Cells(r, 1)
        coll.Add numero
    Next r

    ur = wsCavoli.Cells(Rows.Count, "I").End(xlUp).Row
    lastCol = wsCavoli.Cells(1, wsCavoli.Columns.Count).End(xlToLeft).Column
    For Each k In coll
        numero = k
        Set collValori = New Collection
        For j = 9 To lastCol Step 2
            Set rng = wsCavoli.Range(wsCavoli.Cells(2, j), wsCavoli.Cells(ur, j))
            Set numTrovato = rng.Find(What:=numero, LookIn:=xlValues, LookAt:=xlWhole)
            If Not numTrovato Is Nothing Then
                firstAddress = numTrovato.Address
                Do
                    valore = numTrovato.Offset(, 1).Value
                    collValori.Add valore
                Set numTrovato = rng.FindNext(numTrovato)
                Loop While Not numTrovato Is Nothing And firstAddress <> numTrovato.Address
            End If
        Next j
        
        If collValori.Count > 0 Then
            ReDim arrValori(1 To collValori.Count)
            For j = LBound(arrValori) To UBound(arrValori)
                arrValori(j) = collValori(j)
            Next j
            
            For r = LBound(arrValori) To UBound(arrValori) - 1
                For c = r + 1 To UBound(arrValori)
                    If arrValori(r) > arrValori(c) Then
                        tempArray = arrValori(r)
                        arrValori(r) = arrValori(c)
                        arrValori(c) = tempArray
                    End If
                Next c
            Next r
            
            rigoNumero = Application.Match(numero, wsValore.Range("A:A"), 0)
            If Not IsError(rigoNumero) Then
                For c = 2 To 21
                    For r = LBound(arrValori) To UBound(arrValori)
                        If Val(wsValore.Cells(1, c).Value) = arrValori(r) Then
                            wsValore.Cells(rigoNumero, c).Value = wsValore.Cells(rigoNumero, c).Value + 1
                        End If
                    Next r
                Next c
            End If
        End If
        Set collValori = Nothing
    Next k

    MsgBox "Fatto!", vbInformation
    
safetyExit:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    Set wsValore = Nothing
    Set wsCavoli = Nothing
    Set coll = Nothing
    Set rng = Nothing
    Set numTrovato = Nothing
    
    Exit Sub

GestError:
    MsgBox "Errore nr: " & Err.Number & " - " & Err.Description, vbCritical
    Resume safetyExit
End Sub

[mauri27Partecipante mauri27]

si perfetto, funziona!!! complimenti e un grazie a tutti. 

[alexps81Moderatore alexps81 Karma: 58 pts]

Ottimo, grande VF  

[Autore]

Articoli