Previous page | 1 | Next page
Facebook  

Cerca, estrai e copia

Last Update: 2/17/2019 9:16 PM
Author
Print | Email Notification    
Post: 32
Registered in: 2/6/2017
Junior User
2016
OFFLINE
2/16/2019 3:43 PM
 
Modify
 
Delete
 
Quote

Salve cerco il vostro aiuto, ho questa macro che mi dovrebbe cercare, estrarre e copiare una serie di numeri, anche se non rispecchia l'ordine di inserimento nelle celle, e dovrebbe poi copiare l'intera riga, invece mi copia la riga anche se trova un solo numero. Non sono riuscito a trovare il perchè, pertanto chiedo il vostro aiuto. Vi posto il codice e allego il file

Sub cerca()
Application.ScreenUpdating = False
Dim Ur, X, R, n0, n1, n2, n3, n4, n5
n0 = Application.WorksheetFunction.CountIf(Range("L2:U2"), 0)
n1 = Application.WorksheetFunction.CountIf(Range("L2:U2"), 1)
n2 = Application.WorksheetFunction.CountIf(Range("L2:U2"), 2)
n3 = Application.WorksheetFunction.CountIf(Range("L2:U2"), 3)
n4 = Application.WorksheetFunction.CountIf(Range("L2:U2"), 4)
n5 = Application.WorksheetFunction.CountIf(Range("L2:U2"), 5)
Ur = Range("L" & Rows.Count).End(xlUp).Row
If Ur = 1 Then Range("Y2:AC" & Ur).Select
Range("Y2").Activate
Selection.ClearContents
Ur = Range("A" & Rows.Count).End(xlUp).Row
R = 2
For X = 1 To Ur
If Application.WorksheetFunction.CountIf(Range("A" & X & ":E" & X), 0) = n0 _
And Application.WorksheetFunction.CountIf(Range("A" & X & ":E" & X), 1) = n1 _
And Application.WorksheetFunction.CountIf(Range("A" & X & ":E" & X), 2) = n2 _
And Application.WorksheetFunction.CountIf(Range("A" & X & ":E" & X), 3) = n3 _
And Application.WorksheetFunction.CountIf(Range("A" & X & ":E" & X), 4) = n4 _
And Application.WorksheetFunction.CountIf(Range("A" & X & ":E" & X), 5) = n5 Then

Range("A" & X & ":E" & X).Copy
Range("Y" & R & ":AC" & R).PasteSpecial
R = R + 1
End If
Next X
MsgBox "Fatto"
Application.ScreenUpdating = True
End Sub

Ringrazio anticipatamente
[Edited by Antonio Romano.2017 2/16/2019 3:43 PM]
CERCA VERT?cerca6/5/2019 11:16 AM by f.bragaglia
Problema risultati funzione "cerca"Assistenza FreeForumZonecerca6/13/2019 9:37 AM by admin
Tumori : Tumore al seno, un nuovo farmaco salva la vita al 70% delle giovaniNews Forumcerca6/3/2019 2:01 PM by angelico
Post: 2,143
Registered in: 4/6/2013
Location: ROMA
Age: 71
Veteran User
2010
OFFLINE
2/16/2019 4:21 PM
 
Modify
 
Delete
 
Quote

ciao
non capisco:
perchè assegni a n0-n1...ecc quanti 0,1,2,3,4,5 ci sono da L2 a U2, al posto di assegnare i reali valori presenti in tale range per poi confrontarli con la tabella di sinistra?

saluti



Domenico
Win 10 - Excel 2016
Post: 32
Registered in: 2/6/2017
Junior User
2016
OFFLINE
2/16/2019 8:15 PM
 
Modify
 
Delete
 
Quote

cerca,estrai e copia
Il file che ho postato è solo una prova, ma le colonne sono decine di migliaia... e la macro deve valutare cella per cella i 5 valori.... solo che mi estrae, a volte effettivamente solo la riga con i 5 valori altre volte mi estrae la riga con i valori che sono di meno..
[Edited by Antonio Romano.2017 2/16/2019 8:16 PM]
Post: 3,259
Registered in: 4/3/2013
Master User
Excel 2000 - 2013
OFFLINE
2/17/2019 11:23 AM
 
Modify
 
Delete
 
Quote

Buona giornata Antonio.
@Antonio Romano.2017, scrive:


... le colonne sono decine di migliaia ...


se le "decine di migliaia" solo le Righe e non le Colonne, potresti provare con questo Codice VBA:

Option Explicit

Sub Cerca()
Application.ScreenUpdating = False
Dim NRg As Long, x As Long, k As Long
Dim y As Byte, z As Byte, w As Byte
Dim Vlr(5)

    For x = 1 To 5
        Vlr(x) = Cells(2, 11 + x)
    Next x
        NRg = Range("Y" & Rows.Count).End(xlUp).Row
            If NRg < 2 Then NRg = 2
        Range(Cells(2, 25), Cells(NRg, 29)).ClearContents
        
        NRg = Range("A" & Rows.Count).End(xlUp).Row
            k = 2
    For x = 3 To NRg
        z = 0
        Cells(x, 1).Select
            For y = 1 To 5
                For w = 1 To 5
                    If Cells(x, y).Value = Vlr(w) Then z = z + 1
                Next w
            Next y
        If z = 5 Then
            Range(Cells(x, 1), Cells(x, 5)).Copy Cells(k, 25)
                k = k + 1
        End If
    Next x
Application.ScreenUpdating = True
End Sub


Trattandosi di decine di migliaia di Record, sono da verificare i tempi di esecuzione.




A disposizione.

Buon fine settimana.

Giuseppe

Windows XP - Excel 2000
Windows 10 - Excel 2013
Post: 33
Registered in: 2/6/2017
Junior User
2016
OFFLINE
2/17/2019 9:16 PM
 
Modify
 
Delete
 
Quote

Grazie Giuseppe, ottima…
[Edited by Antonio Romano.2017 2/17/2019 9:27 PM]
Admin Thread: | Close | Move | Delete | Modify | Email Notification Previous page | 1 | Next page
New Thread
 | 
Reply
Cerca nel forum
Tag discussione
Discussioni Simili   [vedi tutte]
Home Forum | Bacheca | Album | Users | Search | Log In | Register | Admin
Tutti gli orari sono GMT+01:00. Adesso sono le 11:41 PM. : Printable | Mobile | Regolamento | Privacy
FreeForumZone [v.5.0.0] - Copyright © 2000-2019 FFZ srl - www.freeforumzone.com