Find con 10 indirizzi id

Hai un problema con Excel?

Nuova discussione

Find con 10 indirizzi id
di Nicola (utente non iscritto) data: 05/02/2015 11:52:33
Buongiorno a tutti....

Ciao Vecchio Frac.....ho seguito il tuo consiglio e sto cercando di creare da 10 codici un unico codice che analizzi con find 10 indirizzi id ...

Inserisco il codice che ho scritto .....Mi auguro di aver capito almeno un pochino il lavoro da te suggerito

Private Sub cmdimp1_10_Click()
Call cmdimp1_Click(ur:=Uriga1, col1:=12, col2:=2, col3:=13, col4:=3)
Call cmdimp1_Click(ur2:=Uriga3, col1:=14, col2:=5, col3:=15, col4:=6)
Call cmdimp1_Click(ur3:=Uriga4, col1:=16, col2:=8, col3:=17, col4:=9)
Call cmdimp1_Click(ur4:=Uriga5, col1:=18, col2:=11, col3:=19, col4:=12)
Call cmdimp1_Click(ur5:=Uriga6, col1:=20, col2:=14, col3:=21, col4:=15)
Call cmdimp1_Click(ur6:=Uriga7, col1:=22, col2:=17, col3:=23, col4:=18)
Call cmdimp1_Click(ur7:=Uriga8, col1:=24, col2:=20, col3:=25, col4:=21)
Call cmdimp1_Click(ur8:=Uriga9, col1:=26, col2:=23, col3:=27, col4:=24)
Call cmdimp1_Click(ur9:=Uriga10, col1:=28, col2:=26, col3:=29, col4:=27)
Call cmdimp1_Click(ur10:=Uriga11, col1:=30, col2:=29, col3:=31, col4:=30)
End Sub

Private Sub cmdimp1_Click()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet

Dim Area As Range, RR As Range
Dim Uriga1 As Long, Uriga2 As Long, R As Long, X As Long
Dim ur As Long, ur2 As Long, ur3 As Long, ur4 As Long, ur5 As Long, ur6 As Long, ur7 As Long, ur8 As Long, ur9 As Long, ur10 As Long
Dim col1 As Long, col2 As Long, col3 As Long, col4 As Long
Dim ID As String, percorso As String, nomeFile As String

Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("Db_buyer")

Application.ScreenUpdating = False
Application.EnableEvents = False


'On Error Resume Next

Uriga2 = ws1.Range("E" & ws1.Rows.Count).End(xlUp).Row
percorso = "\CLUSTERFSSharePiano MarketingDb_promo_buyerDb_miglior_promo.xlsm"
Set wb2 = Application.Workbooks.Open(percorso)
Set ws2 = wb2.Worksheets("Promo_buyer")

Uriga1 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
Set Area = ws2.Range("A1:A" & Uriga1)
Uriga3 = ws2.Range("D" & ws2.Rows.Count).End(xlUp).Row
Set Area = ws2.Range("D1:D" & Uriga3)
Uriga4 = ws2.Range("G" & ws2.Rows.Count).End(xlUp).Row
Set Area = ws2.Range("G1:G" & Uriga4)
Uriga5 = ws2.Range("J" & ws2.Rows.Count).End(xlUp).Row
Set Area = ws2.Range("J1:J" & Uriga5)
Uriga6 = ws2.Range("M" & ws2.Rows.Count).End(xlUp).Row
Set Area = ws2.Range("M1:M" & Uriga6)
Uriga7 = ws2.Range("P" & ws2.Rows.Count).End(xlUp).Row
Set Area = ws2.Range("P1:P" & Uriga7)
Uriga8 = ws2.Range("S" & ws2.Rows.Count).End(xlUp).Row
Set Area = ws2.Range("S1:S" & Uriga8)
Uriga9 = ws2.Range("V" & ws2.Rows.Count).End(xlUp).Row
Set Area = ws2.Range("V1:V" & Uriga9)
Uriga10 = ws2.Range("Y" & ws2.Rows.Count).End(xlUp).Row
Set Area = ws2.Range("Y1:Y" & Uriga10)
Uriga11 = ws2.Range("AB" & ws2.Rows.Count).End(xlUp).Row
Set Area = ws2.Range("AB1:AB" & Uriga11)

For X = 3 To Uriga2

ID = ws1.Cells(X, 5).Value
  
  Set RR = Area.Find(ID, LookIn:=xlValues, Lookat:=xlWhole)
  
  If Not RR Is Nothing Then
    ws1.Cells(X, col1) = ws2.Cells(RR.Row, col2)
    ws1.Cells(X, col3) = ws2.Cells(RR.Row, col4)
   
   Set RR = Nothing
  End If
Next X

Application.ScreenUpdating = True
Application.EnableEvents = True
wb2.Close SaveChanges:=True
Application.DisplayAlerts = True

'MsgBox "Aggiornamento eseguito con successo"

Set ws1 = Nothing
Set wb1 = Nothing
Set ws2 = Nothing
Set wb2 = Nothing
Set Area = Nothing
End Sub

di Vecchio Frac data: 05/02/2015 14:50:39
Mah, gli schiaffi non sono stati sufficienti ^_^
Cioè... non è che non hai capito... hai applicato in modo diversamente corretto :)
Adesso proprio non ho possibilità di spiegarti meglio... devo rinviare a un momento più libero.
Find con 10 indirizzi id
di Nicola (utente non iscritto) data: 05/02/2015 15:08:12
Non ti preoccupare .....quando sei libero mi farà piacere una tua spigazione.....

grazie mille
di Raffaele_53 (utente non iscritto) data: 05/02/2015 15:24:35
Option Explicit ' meglio se lo metti in riga1
Dichiari Ur1,ur3,ur4 ecc ecc e poi usi Uriga1,Uriga3.ecc ecc...Uriga10
quando arrivi alla riga For X = 3 To Uriga2--> Area sarà = ws2.Range("AB1:AB" & Uriga11), cosa è servito dichiarare tutte le righe precedenti?
Dichiari Application.DisplayAlerts = True, ma non l'hai mai messa =False
Manca Set RR = Nothing

Se fai un'allegato d'esempio fatto solo con due fogli (come se fossero i due file) e qualche spiegazione in più perchè
Call cmdimp1(ur:=Uriga1, col1:=12, col2:=2, col3:=13, col4:=3) non lo capisco e mi da errore.
Find con 10 indirizzi id
di Nicola (utente non iscritto) data: 05/02/2015 16:03:39
Ciao Raffaele...hai ragione ...non sono stato molto preciso nella spiegazione......

in precedenza avevo creato 10 routine quasi identiche dove cambiava solo questa riga di codice
e le colonne da dove attingere i dati..

Uriga1 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
Set Area = ws2.Range("A1:A" & Uriga1)

Il grande Vecchio frac....mi aveva dato una dritta per creare un unico codice ....è quindi ci stavo provando.....((anche se male))....

di Raffaele_53 (utente non iscritto) data: 05/02/2015 18:35:49
Non ho capito cosa copiare , comunque dagli un occhiata.

Ps anche Private Sub cmdimp1_10_Click() non ho capito

Private Sub cmdimp1_Click()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet

Dim Area As Range, RR As Range, Y As Long, X As Long
'Dim Urow As Long, Ur2 As Long, Urow2 As Long, Urow3 As Long, Urow4 As Long, Urow5 As Long, Urow6 As Long, Urow7 As Long, Urow8 As Long, Urow9 As Long, Urow10 As Long, R As Long, X As Long
Dim Ur1 As Long
Dim col1 As Long, col2 As Long, col3 As Long ', col4 As Long
Dim ID As String, percorso As String, nomeFile As String

Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("Db_buyer")

Application.ScreenUpdating = False
Application.EnableEvents = False

'On Error Resume Next

Ur1 = ws1.Range("E" & ws1.Rows.Count).End(xlUp).Row
percorso = "C:Documents and SettingsLello-SatDesktopDb_miglior_promo.xlsm" '"\CLUSTERFSSharePiano MarketingDb_promo_buyerDb_miglior_promo.xlsm"
Set wb2 = Application.Workbooks.Open(percorso)
Set ws2 = wb2.Worksheets("Promo_buyer")


'non setto l'area e non calcolo quanto sono lunghe le colonne, metto 1000000
For X = 3 To Ur1
col1 = 1
col2 = 2
col3 = 3
ID = ws1.Cells(X, 5).Value
    For Y = 1 To 10
        Set RR = ws2.Range(ws2.Cells(1000000, col1), ws2.Cells(Y, col1)).Find(ID, LookIn:=xlValues)
        If Not RR Is Nothing Then
            ' non so in quale cella copiare 'ws1.Cells(X, ???) = ws2.Cells(RR.Row, col1 + 1)
            ' non so in quale cella copiare 'ws1.Cells(X, ???) = ws2.Cells(RR.Row, col1 + 2)
            MsgBox "Trovato"
            'Set RR = Nothing
        End If
        col1 = col1 + 3
        col2 = col2 + 3
        col3 = col3 + 3
    Next Y
Next X

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = False
wb2.Close SaveChanges:=True
Application.DisplayAlerts = True

MsgBox "Aggiornamento eseguito con successo"

Set ws1 = Nothing
Set wb1 = Nothing
Set ws2 = Nothing
Set wb2 = Nothing
Set RR = Nothing
End Sub

di Vecchio Frac data: 05/02/2015 18:45:36
Lasciando stare il titolo che mi dai, vediamo di impostare un ragionamento...

Hai dieci pulsanti di comando activex (command button).
Ognuno fa qualcosa di sostanzialmente simile perchè agisce in pratica solo su range diversi.
Sai che ogni pulsante si attiva scrivendo del codice che reagisce all'evento _Click del pulsante.
Per risparmiare digitazione (e lunghezza del codice, quindi leggibilità del listato) puoi accorpare le parti di codice comune a tutti i command button in una unica procedura, che puoi richiamare ai clic dei pulsanti. Però non puoi esimerti (allo stato delle tue conoscenze) dallo scrivere tutte le routine associate all'evento click di ogni pulsante!
La procedura comune saprà fare la cosa giusta se le passiamo l'informazione che differenzia, cioè caratterizza, ogni pressione dei singoli pulsanti (se ognuno facesse la medesima cosa non ci sarebbe bisogno di tanti pulsanti... ne basterebbe uno solo). Ecco il famoso "passaggio di parametri" che sai riconoscere e che sai scrivere: questi parametri informano la procedura che li accoglie su quali sono le informazioni vitali da prendere in considerazione, da trattare quindi nel corso della sua esecuzione.

Questa riga:
Private Sub cmdimp1_10_Click()
dice solo che quando viene premuto il pulsante che si chiama "cmdimp1_10" allora rinvia l'esecuzione alla procedura chiamata "cmdimp1_Click" con una serie di parametri. Peccato che non è quello che volevi fare tu :)

Vai a vedere il thread precedente e il mio esempio... noterai che la firma della sub con parametri chiamata in modo infame "chiamala_come_vuoi" (la firma è la prima riga, quella con Private Sub) è diversa da quella che hai proposto qui, dove non c'è traccia dei parametri che richiami.

Quindi: ricomincia. Lascia perdere il corpo della sub che richiami. Scrivimi qui adesso solo il prototipo delle tue sub, lascia perdere *tutto* il codice. Partiamo dal basso e piano piano ci arriviamo... sempre se hai fretta ma naturalmente non devi averne ;)

p.s. il consiglio di Raffaele su Option Explicit ci sta tutto :)
p.s.2: A Raffaele manca il thread precedente: excelvba.it/Forum/thread.php?f=1&t=8023
di Vecchio Frac data: 05/02/2015 18:46:37
@Raffaele
Ho visto adesso la tua risposta.
Sto cercando di portare piano piano Nicola al ragionamento perchè gli mancano le basi (e a te manca il thread precedente, ecco perchè ci sono cose che non comprendi).
di Raffaele_53 (utente non iscritto) data: 05/02/2015 19:15:13
Ciao VF
mi sono letto il post.
Mi ero dimenticato d'avvisare che nel secondo file i dati devono partire da riga2 (oppure find non trova quelli in riga1)
di Vecchio Frac data: 05/02/2015 20:27:22
@Raffaele
Sei più avanti di me, io non ho ancora affrontato il problema vero (lo lasciavo alla fantasia del Nostro) ^_^
di Raffaele_53 (utente non iscritto) data: 05/02/2015 20:36:43
Per fortuna che sono più avanti
Vedi cosa ho scritto--->Set RR = ws2.Range(ws2.Cells(1000000, col1), ws2.Cells(Y, col1)).Find(ID, LookIn:=xlValues)

Per altri lettori dovrebbe essere --->Set RR = ws2.Range(ws2.Cells(1, col1), ws2.Cells(1000000, col1)).Find(ID, LookIn:=xlValues)...senza aver trovato le altre magagne mie (purtoppo non ho potuto provare)
di Vecchio Frac data: 05/02/2015 21:07:49
Ma secondo me non ha molta importanza per Nicola, adesso, che deve ancora digerire i concetti che gli ho esposto ^_^
Le correzioni al (suo e anche al tuo) codice riuscirà a farle anche lui tra un paio di giorni :P
E comunque sì, hai comunque sintetizzato bene :)
Find con 10 indirizzi id
di nicola (utente non iscritto) data: 05/02/2015 21:47:28
ciao Vecchio frac è raffaele....

ho letto con molta attenzione ...la spiegazione sul codice che vorrei riuscire a fare...
Ps..mi scuso per non aver spiegato al meglio il compito della routine...

Quando vecchio frac dice che mi mancano le basi ha perfettamente ragione....Ma grazie ai Vs preziosi insegnamenti qualcosina inizio a capirla....

Domani mattina nuovamente mi butterò sul codice.....

Grazie vecchio frac per l ottima spiegazione....

notte

Find con 10 indirizzi id
di Nicola (utente non iscritto) data: 06/02/2015 11:19:48
Ciao Vecchio Frac e Raffaele...

Ho cercato di creare la routine che dovrebbe in teoria scorrere tra le varie colonne del del Db_miglior_promo.xlsm e inserire i dati corrispondenti nel db_buyer

il mio problema come sapete è dato dal fatto che le colonne sono diverse ....

Quindi ho trovato difficoltà a trovare l'ntervallo dell 'aria....((chaf...chaf))

Ho spigato meglio nel codice sotto...riga per riga...

Vecchi frac...mi sto applicando tantissimo....perdonami se non arrivo subito alla soluzione...l

Grazie grazie

Option Explicit

Private Sub cmdtrovapromo_Click()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Area As Range, RR As Range
Dim R As Long, X As Long
Dim urigafrom As Long, urigato As Long
Dim col1 As Long
Dim ID As String, percorso As String, nomeFile As String

Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("Db_buyer")
Application.ScreenUpdating = False
Application.EnableEvents = False

'On Error Resume Next

urigato = ws1.Range("E" & ws1.Rows.Count).End(xlUp).Row ' seleziono l'intero intervallo da verificare

percorso = "\CLUSTERFSSharePiano MarketingDb_promo_buyerDb_miglior_promo.xlsm" ' apro il percorso dove cercare i dati

Set wb2 = Application.Workbooks.Open(percorso)
Set ws2 = wb2.Worksheets("Promo_buyer")

'ora dovrei trovare gli intervalli e le aree da dove prendere i dati
'che sono "A","D","G","J","M","P","S","V","Y","AB" (((Per un totale di 10 aree)))

urigafrom = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row ' intervallo "A"

Set Area = ws2.Range("A1:A" & urigafrom) ' area "A"


For X = 3 To urigato ' parto dalla riga 3 + ultima riga del range "E"

col1 = 1 ' creo la variabile colonna 1 e quando dovrò spostarmi di colonna metto il + n (Es col1 +3)

ID = ws1.Cells(X, 5).Value ' devo trovare i riferimenti della colonna 5 nelle 10 aree
  
  'é qui mi casca la testa
  ''''''''''''''''''''''''
  
  Set RR = Area.Find(ID, LookIn:=xlValues, Lookat:=xlWhole)
  
  If Not RR Is Nothing Then
    ws1.Cells(X, col1 + 11) = ws2.Cells(RR.Row, col1 + 1) 'esempio con area a
    ws1.Cells(X, col1 + 12) = ws2.Cells(RR.Row, col1 + 2) 'esempio con aria a
   
'''ps qui mi fermo perchè non capisco ...purtroppo .....le troppe aree mi hanno incasinato
   
   
   
   Set RR = Nothing
  End If
Next X

Application.ScreenUpdating = True
Application.EnableEvents = True
wb2.Close SaveChanges:=True
Application.DisplayAlerts = True

'MsgBox "Aggiornamento eseguito con successo"

Set ws1 = Nothing
Set wb1 = Nothing
Set ws2 = Nothing
Set wb2 = Nothing
Set Area = Nothing
End Sub

di Raffaele_53 (utente non iscritto) data: 06/02/2015 12:14:48
Ieri mi ero dimenticato un'altro particolare (quando ricerchi e trovi...scrivi alcune celle..a questo punto la ricerca deve continuare per forza nelle altre colonne?, oppure uscire per "quel ID"?

Il Tuo problema che hai dieci colonne dove ricercare
Allora ci devono essere due cicli For, uno dentro l'altro
Find con 10 indirizzi id
di Nicola (utente non iscritto) data: 06/02/2015 12:34:10
L id è sempre quello ossia "ID = ws1.Cells(X, 5).Value"

ciò che cambia e la colonna dove fare la ricerca....

Inserito nel codice di spigazione:

'ora dovrei trovare gli intervalli e le aree da dove prendere i dati
'che sono "A","D","G","J","M","P","S","V","Y","AB" (((Per un totale di 10 aree)))

Spero di essere chiaro
di Raffaele_53 (utente non iscritto) data: 06/02/2015 12:51:22
OK e come detto devi fare due cicli for

Sta a te decidere come farli
Ogni ID e poi ricercare per ogni colonna (qui avresti "forse" un vantaggio se sai cosa fare "1 riga" del mio post precedente)
Oppure ricercare tutti gli ID in una colonna e poi ripetere il tutto per altre 9 colonne?
Find con 10 indirizzi id
di Nicola (utente non iscritto) data: 06/02/2015 14:34:23
Sapendo che ho le colonne fisse dove trovare per ciascun a di esse Id "ID = ws1.Cells(X, 5).Value"
'che sono "A","D","G","J","M","P","S","V","Y","AB" (((Per un totale di 10 aree)))

Scolasticamente parlando vorrei scrivere un codice che :
1..Trova id nella colla "A" e inserisce i dati della colonna "B e C"
2..Trova id nella colla "D" e inserisce i dati della colonna "E e F"
3..Trova id nella colla "G" e inserisce i dati della colonna "H e I"
.....
fino alla colonna AB.
codice Raffaele
'non setto l'area e non calcolo quanto sono lunghe le colonne, metto 1000000(((COME FACCIO A SETTARE L'ARIA SENZA METTERE UN NEMERO A CASO?????
'For X = 3 To Ur1
col1 = 1
col2 = 2
col3 = 3
ID = ws1.Cells(X, 5).Value
For Y = 1 To 10
Set RR = ws2.Range(ws2.Cells(1000000, col1), ws2.Cells(Y, col1)).Find(ID, LookIn:=xlValues)
If Not RR Is Nothing Then
' non so in quale cella copiare 'ws1.Cells(X, ???) = ws2.Cells(RR.Row, col1 + 1)
' non so in quale cella copiare 'ws1.Cells(X, ???) = ws2.Cells(RR.Row, col1 + 2)
MsgBox "Trovato"
'Set RR = Nothing
End If
col1 = col1 + 3
col2 = col2 + 3
col3 = col3 + 3
Next Y
Next X
Find con 10 indirizzi id
di Nicola (utente non iscritto) data: 06/02/2015 14:54:45
Scolasticamente parlando vorrei scrivere un codice che :
1..Trova "ID = ws1.Cells(X, 5).Value" nella colla "A" e inserisce i dati della colonna "B e C" del db_buyer nelle colonne 12/13
2..Trova "ID = ws1.Cells(X, 5).Value" nella colla "D" e inserisce i dati della colonna "E e F" del
db_buyer nelle colonne 14/15
3..Trova "ID = ws1.Cells(X, 5).Value" nella colla "G" e inserisce i dati della colonna "H e I" del
db_buyer nelle colonne 16/17
.....
fino alla colonna AB.
di Raffaele_53 (utente non iscritto) data: 06/02/2015 15:00:45
Premesso che find ci impiega solo un secondo in una colonna
Avrai ragione nel dire che se l'area è più piccola ci mette di meno...

Per non incasinarTi ho messo un numero a caso =1000000 (non conosco il comando giusto digitando la colonna come numero. Oppure una Function che allego)
Mà il risultato non cambia molto, anche se non descrivo l'area perbene

Allora il for X esegue tutti gli ID
...Post precedente =Per altri lettori dovrebbe essere --->Set RR = ws2.Range(ws2.Cells(1, col1), ws2.Cells(1000000, col1)).Find(ID, LookIn:=xlValues)
Il for Y esegue per ogni colonna (dato che ho notato che sono ogni tre colonne), alla fine del Y gli metto col1 = col1 + 3
Ma come Ti ho richiesto (cosa fare se lo trova?)
Ps. Vedi che uso il modo di VF (per farTi capire). Usando la Function puoi settare l'area perbene
Public Function LettCol(ByVal n As Long) As String 'By Scossa LettCol = Replace(Cells(1, n).Address(False, False), "1", "") End Function
di Raffaele_53 (utente non iscritto) data: 06/02/2015 15:05:22
>>>alla fine del Y gli metto col1 = col1 + 3
Qui ho scritto la mia solita cavolata .....alla fine del Y gli metto col1 = col1 + 2
di Raffaele_53 (utente non iscritto) data: 06/02/2015 15:10:32
Ho letto il Tuo ultimo post e vdo che per ogni ricerca scrivi iin differenti celle.
Ti suggerisco d'usare il comando Case
Find con 10 indirizzi id
di Nicola (utente non iscritto) data: 06/02/2015 15:14:36
Scusa Raffaele .....capisco che ci impiega un secondo a trovare l'id....ma lo chiedo per una mia formazione e curiosità...

Se trovo l id nelle colonne "A","D","G","J","M","P","S","V","Y","AB"....cosa fare????
1..Trova "ID = ws1.Cells(X, 5).Value" nella colla "A" e inserisce i dati della colonna "B e C" nel db_buyer nelle colonne 12/13
2..Trova "ID = ws1.Cells(X, 5).Value" nella colla "D" e inserisce i dati della colonna "E e F" nel
db_buyer nelle colonne 14/15
3..Trova "ID = ws1.Cells(X, 5).Value" nella colla "G" e inserisce i dati della colonna "H e I" del
db_buyer nelle colonne 16/17
.....
fino alla colonna AB.

In allegato il risultato che dovrebbe dare il la routine
di Raffaele_53 (utente non iscritto) data: 06/02/2015 15:29:47
Io credo d'aver capito il problema (di sicuro non saprei in quale cella copiare)

La domanda sarebbe...Vuoi un codice finale?, oppure come dice VF "dei suggerimenti per capire"?
Lascia perdere le colonne e dove copiare.

Hai capito che il ciclo for X eseguirà tutti gli ID
Adesso parliamo del ciclo for Y
In teoria come detto farà tutte le colonne che desideri, ma a questo punto soppraggiunge un'altro problema
(copiare in celle distinte..., significa che se trova la corrispondenza in una colonna dovra copiare in celle xxxx)
di Vecchio Frac data: 06/02/2015 15:41:19
cit. "mi sto applicando tantissimo....perdonami se non arrivo subito alla soluzione..."
---> Sono contento che ti applichi! ognuno ha i suoi tempi.
Non mi intrometto se Raffaele ti sta aiutando a concludere ma vorrei che ti fossero chiari i passaggi e i concetti, altrimenti la soluzione finale ti resterà sempre oscura e, soprattutto, in caso di necessità di modifiche, cambiamenti, miglioramenti o correzione di errori, non saprai dove mettere le mani :)

Find con 10 indirizzi id
di Nicola (utente non iscritto) data: 06/02/2015 15:47:00
Quello di sotto è un codice che uso per trovare id nell'area A è inserisce attraverso il ciclo for i dati della colonna 2/3 nelle colonne 12/13....

Di questi codici ne ho creati 10.....

è funzionano tutti...

Il ciclo For x..è digerito alla grande....attraverso set area sappiamo dove vanno a finire i dati nelle celle.

Ora la mia sfida è creare solo un codice che vada a sostituire i 10 precedenti...

.....Dentro la mia testa e hai miei ragionamenti ....

Volevo settare l'area da a a ab ....è attraverso If Not RR Is Nothing Then
ws1.Cells(X, 12) = ws2.Cells(RR.Row, 2)
ws1.Cells(X, 13) = ws2.Cells(RR.Row, 3)
modificare semplicemente il numero di colonne di input e output

Private Sub cmdimp1_Click()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet

Dim Area As Range, RR As Range
Dim Uriga1 As Long, Uriga2 As Long, R As Long, X As Long
Dim ID As String, percorso As String, nomeFile As String

Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("Db_buyer")

Application.ScreenUpdating = False
Application.EnableEvents = False

'On Error Resume Next

Uriga2 = ws1.Range("E" & ws1.Rows.Count).End(xlUp).Row
percorso = "\CLUSTERFSSharePiano MarketingDb_promo_buyerDb_miglior_promo.xlsm"
Set wb2 = Application.Workbooks.Open(percorso)
Set ws2 = wb2.Worksheets("Promo_buyer")

Uriga1 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
Set Area = ws2.Range("A1:A" & Uriga1)

For X = 3 To Uriga2
ID = ws1.Cells(X, 5).Value
  Set RR = Area.Find(ID, LookIn:=xlValues, Lookat:=xlWhole)
  If Not RR Is Nothing Then
    ws1.Cells(X, 12) = ws2.Cells(RR.Row, 2)
    ws1.Cells(X, 13) = ws2.Cells(RR.Row, 3)
   
    Set RR = Nothing
  End If
Next X

Application.ScreenUpdating = True
Application.EnableEvents = True
wb2.Close SaveChanges:=True
Application.DisplayAlerts = True

'MsgBox "Aggiornamento eseguito con successo"

Set ws1 = Nothing
Set wb1 = Nothing
Set ws2 = Nothing
Set wb2 = Nothing
Set Area = Nothing
End Sub

Find con 10 indirizzi id
di Nicola (utente non iscritto) data: 06/02/2015 15:56:04
Ciao Vecchio frac...sto iniziando a dare numeri.....

Volevo settare l'area da a a ab ....è attraverso If Not RR Is Nothing Then
ws1.Cells(X, 12) = ws2.Cells(RR.Row, 2)
ws1.Cells(X, 13) = ws2.Cells(RR.Row, 3)
modificare semplicemente il numero di colonne di input e output

Pensavo fosse più semplice la soluzione....ma come dici tu....anche se studio ((libri))) e sono un appassionato di questo bellissimo forum......

Basta cambiare una piccola virgola di codice che magari non ho mai visto e vado in tilt...
(())
Find con 10 indirizzi id
di Nicola (utente non iscritto) data: 06/02/2015 16:31:24
cit Raffaele
Adesso parliamo del ciclo for Y
In teoria come detto farà tutte le colonne che desideri, ma a questo punto soppraggiunge un'altro problema
(copiare in celle distinte..., significa che se trova la corrispondenza in una colonna dovra copiare in celle xxxx)
......For Y = 1 To 10.......Ps le colonne nel db_miglior_promo sono 28......
Perché far fare un ciclo for Y eccc...se ho con sicurezza le colonne da ricercare (((("A","D","G","J","M","P","S","V","Y","AB"....))))
Sbaglio il ragionamento??????
di Raffaele_53 (utente non iscritto) data: 06/02/2015 16:45:51
Il codice è pronto, mà me lo deve dire VF

Dopo tanti interventi si va in tilt. OK
Mi sembra che hai gia fatto il ciclo per la colonna A, io toglierei quel NOT, metterei un Else e toglierei Set RR = Nothing. EX

Ma come ti ho già detto ci vogliono due cicli for, Dove X per gli ID, l'altro per le colonne e dopo anche un CASE
Tu hai settato l'area prima del ciclo For--->Set Area = ws2.Range("A1:A" & Uriga1), dopo non potrai più cambiarla, se invece la metti dentro...

For X = 3 To Uriga2...OK
ID = ws1.Cells(X, 5).Value...OK
For Y = 1 to 10
Qui puoi settare l'area che desideri anche se non serve settarla, usando la function puoi scrivere...

For X = 3 To Uriga2
ID = ws1.Cells(X, 5).Value...OK
Col1 = 1
For Y = 1 to 10
Uriga2 = sh2.Range(LettCol(Col1) & sh2.Rows.Count).End(xlUp).Row
If RR Is Nothing Then
Else
Siccome devi scrivere in celle diverse si deve usare il comando case
Case "A"
...ws1.Cells(X, 12) = ws2.Cells(RR.Row, 2)
...ws1.Cells(X, 13) = ws2.Cells(RR.Row, 3)
Col1 = col1 + 3
Case "D"
'ecc ecc
Col1 = col1 + 3
'ecc
'ecc
End Select
end if
Next y
Nest X
Find con 10 indirizzi id
di Nicola (utente non iscritto) data: 06/02/2015 16:46:47
Purtroppo per me non riesco ad arrivarci.......
non riesco a capire .......

Che delusione......
di Vecchio Frac data: 06/02/2015 16:48:53
cit. "Il codice è pronto, mà me lo deve dire VF "
---> No, non io... è Nicola che deve sentirsi di guardare una soluzione completa e capire come funziona :)
di Vecchio Frac data: 06/02/2015 16:51:12
cit. "Purtroppo per me non riesco ad arrivarci"
---> Allora prendi una scatola robusta, rovesciala e salici sopra. Così ci arrivi meglio.
Poi respira, fai un passo indietro e analizza una riga alla volta.
Ripensa all'algoritmo (la soluzione del problema) un pezzetto alla volta e svolgilo.
A volte serve suddividere il codice in parti separate, che funzionino, e poi riunirle insieme.
di Raffaele_53 (utente non iscritto) data: 06/02/2015 16:52:46
>>>For Y = 1 To 10
Si ma aggiungendo 3 (non due come detto) arriviamo a 30
Percio fara solo le colonna A, D, ecc ecc
Find con 10 indirizzi id
di Nicola (utente non iscritto) data: 06/02/2015 17:00:00
Vecchio frac......mi dispiace di non essere riuscito a creare questo codice da solo...
Grazie a voi è al mio piccolo bagaglio studiato nei libri....Da quando ho iniziato a creare macro ....per me non è più cosa sconosciuta ,,,,, ma non sono ancora all'altezza di creare codici di questo genere....(((Ps..è normale ????)))

In questo preciso momento vorrei avere il codice è studiarlo riga per riga....per capire al meglio ogni singolo passaggio per arrivare a questa cavolo di soluzione.......
di Vecchio Frac data: 06/02/2015 17:11:52
cit. "è normale"
---> Ma certo che è normale, mi sarei preoccupato se avessi capito tutto e subito ^_^

di Raffaele_53 (utente non iscritto) data: 06/02/2015 17:15:09
Come scritto non so quali celle copiare, naturale che questa sia una bozza da mettere a posto e da completare.
Buon lavoro

Ps. Ogni volta che avvii il codice fallo solo con F8, ripremi ripremi e vedrai passando sopra il Mouse che le variabili Ti dicono (quale valore abbiano) e dove vanno a scrivere

Option Explicit
Sub ricerca()
Dim wb1 As Workbook: Set wb1 = ThisWorkbook
Dim sh1 As Worksheet: Set sh1 = wb1.Worksheets("Db_buyer")
Dim Area As Range, RR As Range
Dim Ur1 As Long, Ur2 As Long, Y As Long, X As Long, Col1 As Long, Col2 As Long, Col3 As Long
Dim ID As String, percorso As String, nomeFile As String

Application.ScreenUpdating = False
Application.EnableEvents = False

Ur1 = sh1.Range("E" & sh1.Rows.Count).End(xlUp).Row
percorso = "C:Documents and SettingsLello-SatDesktopDb_miglior_promo.xlsm" '"\CLUSTERFSSharePiano MarketingDb_promo_buyerDb_miglior_promo.xlsm"
Dim wb2 As Workbook: Set wb2 = Application.Workbooks.Open(percorso) ' da cambiare casomai
Dim sh2 As Worksheet: Set sh2 = wb2.Worksheets("Promo_buyer") ' da cambiare casomai

For X = 3 To Ur1
Col1 = 1
ID = sh1.Cells(X, 5).Value
    For Y = 1 To 10
        Ur2 = sh2.Range(LettCol(Col1) & sh2.Rows.Count).End(xlUp).Row
        Set RR = sh2.Range(sh2.Cells(1, Col1), sh2.Cells(Ur2, Col1)).Find(ID, LookIn:=xlValues) ' non c'è bisogno di fare SET AREA
        If RR Is Nothing Then
        Else
            Select Case LettCol(Col1)
                Case "A"
                    MsgBox "Colonna A = Trovato, se desideri la prima cella destra sh1.(cells(x,???) = sh2.(cells(RR,col1 +1)"
                    MsgBox "Colonna A = Trovato, se desideri la seconda cella destra  sh1.(cells(x,???) = sh2.(cells(RR,col1 +2)"
                    Col1 = Col1 + 3 'dato che non hai risposto e ho trovato ID, aggiungo 3 ed esco dal ciclo
                    Exit For
                Case "D"
                    MsgBox "Cosa fare??????"
                    Exit For 'dato che non hai risposto e ho trovato ID, aggiungo 3 ed esco dal ciclo
                Case "G"
                    MsgBox "Cosa fare??????"
                    Exit For 'dato che non hai risposto e ho trovato ID, aggiungo 3 ed esco dal ciclo
            
            
                ' ne mancano altri 7
                End Select
        End If
    Next Y
Next X
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = False
wb2.Close SaveChanges:=True
Application.DisplayAlerts = True
MsgBox "Aggiornamento eseguito con successo"
Set sh1 = Nothing
Set wb1 = Nothing
Set sh2 = Nothing
Set wb2 = Nothing
Set RR = Nothing
End Sub

di raffaele_53 (utente non iscritto) data: 06/02/2015 17:31:15
Allegato
Find con 10 indirizzi id
di Nicola (utente non iscritto) data: 06/02/2015 17:37:14
Grazie mille Raffaele per il tempo che mi hai dedicato....
Tra oggi e domani cercherò di rendere il codice utilizzabile .....
Come suggerito da Vecchio frac....studierò riga per riga....in quanto per me è troppo importante capire quello che faccio...

Grazie anche a Vecchi frac...che mi ha confortato in questo lavoro....

Vi aggiornerò sul funzionamento del codice....spero di darvi buone notizie ...entro domani .....

wwwww Forum di Excel e VBA(((((())))))
di Raffaele_53 (utente non iscritto) data: 06/02/2015 17:59:40
Ultimo suggerimento, aggiungendo
Dim Col As String

Sotto For Y = to 10 metti
Col = LettCol(Col1)
Ora dove ho scritto LettCol (Col1), puoi mettere semplicemente Col (due volte, una in Ur2 =...e l'altra dopo Select Case)

Ps. I dati di Promo_buyer devono inziare dalla riga2, inoltre sono tutti uguali ed avendo io messo un exit for non potrai capire bene.
Modifica Promo_buyer in modo che in ogni colonna ci siano dati differenti ed incolla un solo dato giusto per ogni colonna
di Raffaele_53 (utente non iscritto) data: 06/02/2015 18:01:25
Sempre che hai inserito in un modulo la Function di scossa
Find con 10 indirizzi id
di nicola (utente non iscritto) data: 06/02/2015 20:13:54
Grazie Raffaele...lo testo domani mattina...ho la testa

Find con 10 indirizzi id
di nicola (utente non iscritto) data: 09/02/2015 12:06:29
Ciao Raffaele ......Eccomi qui.....Ho testato il codice che avevo in sospeso da sabato....Ho cercato di completarlo .......(((La risposta del codice è MsgBox("Aggiornamento eseguito con successo")...

Ma in effetti non accade nulla ....

Cosa Avrò combinato:::::::

Option Explicit
Sub ricerca()
Dim wb1 As Workbook: Set wb1 = ThisWorkbook
Dim sh1 As Worksheet: Set sh1 = wb1.Worksheets("Db_buyer")
Dim Area As Range, RR As Range
Dim Ur1 As Long, Ur2 As Long, Y As Long, X As Long, Col1 As Long, Col2 As Long, Col3 As Long
Dim ID As String, percorso As String, nomeFile As String
Dim Col As String
Application.ScreenUpdating = False
Application.EnableEvents = False

Ur1 = sh1.Range("E" & sh1.Rows.Count).End(xlUp).Row
percorso = "\CLUSTERFSSharePiano MarketingDb_promo_buyerDb_miglior_promo.xlsm"
Dim wb2 As Workbook: Set wb2 = Application.Workbooks.Open(percorso) ' da cambiare casomai
Dim sh2 As Worksheet: Set sh2 = wb2.Worksheets("Promo_buyer") ' da cambiare casomai
For X = 3 To Ur1
Col1 = 1
ID = sh1.Cells(X, 5).Value
    For Y = 1 To 10
        Col = LettCol(Col1)
        Ur2 = sh2.Range(Col & sh2.Rows.Count).End(xlUp).Row
        
        Set RR = sh2.Range(sh2.Cells(1, Col1), sh2.Cells(Ur2, Col1)).Find(ID, LookIn:=xlValues) ' non c'è bisogno di fare SET AREA
        If RR Is Nothing Then
        Else
            Select Case Col
                Case "A"
                    sh1.Cells(X, 12) = sh2.Cells(RR, Col1 + 1)
                    sh1.Cells(X, 13) = sh2.Cells(RR, Col1 + 2)
                    Col1 = Col1 + 3
                Case "D"
                    sh1.Cells(X, 14) = sh2.Cells(RR, Col1 + 4)
                    sh1.Cells(X, 15) = sh2.Cells(RR, Col1 + 5)
                    Col1 = Col1 + 3
              Case "G"
                    sh1.Cells(X, 16) = sh2.Cells(RR, Col1 + 7)
                    sh1.Cells(X, 17) = sh2.Cells(RR, Col1 + 8)
                    Col1 = Col1 + 3
               Case "J"
                    sh1.Cells(X, 18) = sh2.Cells(RR, Col1 + 10)
                    sh1.Cells(X, 19) = sh2.Cells(RR, Col1 + 11)
                    Col1 = Col1 + 3
               Case "M"
                    sh1.Cells(X, 20) = sh2.Cells(RR, Col1 + 13)
                    sh1.Cells(X, 21) = sh2.Cells(RR, Col1 + 14)
                    Col1 = Col1 + 3
               Case "P"
                    sh1.Cells(X, 22) = sh2.Cells(RR, Col1 + 16)
                    sh1.Cells(X, 23) = sh2.Cells(RR, Col1 + 17)
                    Col1 = Col1 + 3
               Case "S"
                    sh1.Cells(X, 24) = sh2.Cells(RR, Col1 + 19)
                    sh1.Cells(X, 25) = sh2.Cells(RR, Col1 + 20)
                    Col1 = Col1 + 21
               Case "V"
                    sh1.Cells(X, 26) = sh2.Cells(RR, Col1 + 22)
                    sh1.Cells(X, 27) = sh2.Cells(RR, Col1 + 23)
                    Col1 = Col1 + 3
               Case "Y"
                    sh1.Cells(X, 28) = sh2.Cells(RR, Col1 + 25)
                    sh1.Cells(X, 29) = sh2.Cells(RR, Col1 + 26)
                    Col1 = Col1 + 3
               Case "AB"
                    sh1.Cells(X, 30) = sh2.Cells(RR, Col1 + 28)
                    sh1.Cells(X, 31) = sh2.Cells(RR, Col1 + 29)
                    Col1 = Col1 + 3
                    
             End Select
        End If
    Next Y
Next X
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = False
wb2.Close SaveChanges:=True
Application.DisplayAlerts = True
MsgBox "Aggiornamento eseguito con successo"
Set sh1 = Nothing
Set wb1 = Nothing
Set sh2 = Nothing
Set wb2 = Nothing
Set RR = Nothing
End Sub

Public Function LettCol(ByVal n As Long) As String 'By Scossa
  LettCol = Replace(Cells(1, n).Address(False, False), "1", "")
End Function

Find con 10 indirizzi id
di nicola (utente non iscritto) data: 09/02/2015 12:19:54
Select Case Col
Case "A"
sh1.Cells(X, 12) = sh2.Cells(RR.Row, Col1 + 1)
sh1.Cells(X, 13) = sh2.Cells(RR.Row, Col1 + 2)
Col1 = Col1 + 3

Ho modificato il codice con "RR.Row" ora

Solo le calonne 12 e 13 vengono compilate....le altre nada

Option Explicit
Sub ricerca()
Dim wb1 As Workbook: Set wb1 = ThisWorkbook
Dim sh1 As Worksheet: Set sh1 = wb1.Worksheets("Db_buyer")
Dim Area As Range, RR As Range
Dim Ur1 As Long, Ur2 As Long, Y As Long, X As Long, Col1 As Long, Col2 As Long, Col3 As Long
Dim ID As String, percorso As String, nomeFile As String
Dim Col As String
Application.ScreenUpdating = False
Application.EnableEvents = False

Ur1 = sh1.Range("E" & sh1.Rows.Count).End(xlUp).Row
percorso = "\CLUSTERFSSharePiano MarketingDb_promo_buyerDb_miglior_promo.xlsm"
Dim wb2 As Workbook: Set wb2 = Application.Workbooks.Open(percorso) ' da cambiare casomai
Dim sh2 As Worksheet: Set sh2 = wb2.Worksheets("Promo_buyer") ' da cambiare casomai
For X = 3 To Ur1
Col1 = 1
ID = sh1.Cells(X, 5).Value
    For Y = 1 To 10
        Col = LettCol(Col1)
        Ur2 = sh2.Range(Col & sh2.Rows.Count).End(xlUp).Row
        
        Set RR = sh2.Range(sh2.Cells(1, Col1), sh2.Cells(Ur2, Col1)).Find(ID, LookIn:=xlValues) ' non c'è bisogno di fare SET AREA
        If RR Is Nothing Then
        Else
            Select Case Col
                Case "A"
                    sh1.Cells(X, 12) = sh2.Cells(RR.Row, Col1 + 1)
                    sh1.Cells(X, 13) = sh2.Cells(RR.Row, Col1 + 2)
                    Col1 = Col1 + 3
                Case "D"
                    sh1.Cells(X, 14) = sh2.Cells(RR.Row, Col1 + 4)
                    sh1.Cells(X, 15) = sh2.Cells(RR.Row, Col1 + 5)
                    Col1 = Col1 + 3
              Case "G"
                    sh1.Cells(X, 16) = sh2.Cells(RR.Row, Col1 + 7)
                    sh1.Cells(X, 17) = sh2.Cells(RR.Row, Col1 + 8)
                    Col1 = Col1 + 3
               Case "J"
                    sh1.Cells(X, 18) = sh2.Cells(RR.Row, Col1 + 10)
                    sh1.Cells(X, 19) = sh2.Cells(RR.Row, Col1 + 11)
                    Col1 = Col1 + 3
               Case "M"
                    sh1.Cells(X, 20) = sh2.Cells(RR.Row, Col1 + 13)
                    sh1.Cells(X, 21) = sh2.Cells(RR.Row, Col1 + 14)
                    Col1 = Col1 + 3
               Case "P"
                    sh1.Cells(X, 22) = sh2.Cells(RR.Row, Col1 + 16)
                    sh1.Cells(X, 23) = sh2.Cells(RR.Row, Col1 + 17)
                    Col1 = Col1 + 3
               Case "S"
                    sh1.Cells(X, 24) = sh2.Cells(RR.Row, Col1 + 19)
                    sh1.Cells(X, 25) = sh2.Cells(RR.Row, Col1 + 20)
                    Col1 = Col1 + 21
               Case "V"
                    sh1.Cells(X, 26) = sh2.Cells(RR.Row, Col1 + 22)
                    sh1.Cells(X, 27) = sh2.Cells(RR.Row, Col1 + 23)
                    Col1 = Col1 + 3
               Case "Y"
                    sh1.Cells(X, 28) = sh2.Cells(RR.Row, Col1 + 25)
                    sh1.Cells(X, 29) = sh2.Cells(RR.Row, Col1 + 26)
                    Col1 = Col1 + 3
               Case "AB"
                    sh1.Cells(X, 30) = sh2.Cells(RR.Row, Col1 + 28)
                    sh1.Cells(X, 31) = sh2.Cells(RR.Row, Col1 + 29)
                    Col1 = Col1 + 3
                    
             End Select
        End If
    Next Y
Next X
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = False
wb2.Close SaveChanges:=True
Application.DisplayAlerts = True
MsgBox "Aggiornamento eseguito con successo"
Set sh1 = Nothing
Set wb1 = Nothing
Set sh2 = Nothing
Set wb2 = Nothing
Set RR = Nothing
End Sub

Find con 10 indirizzi id
di nicola (utente non iscritto) data: 09/02/2015 12:29:46
For Y = 1 To 10 .....E dichiarato nel codice un ciclo for Y....Ma in effetti non viene eseguito ...in quanto non è inserito in nessuna riga di codice.....

Come fareeee::::

di Raffaele_53 (utente non iscritto) data: 09/02/2015 13:06:12
Colpa mia ho messo Col1 = Col1 + 3 in ogni CASE, invece va messo solo prima dell'Else

All' inizio il Col1 e valorizzato = 1 e poi mano mano che aumenterà sino ad arrivare ad 30, pertanto non può essere scritto sh2.Cells(RR.Row, Col1 + 28) 30+28= colonna 58
Per ogni CASE potrà essere solo +1, +2
In aggiungerei anche un exit for subito dopo

Prova così

'..........
        If RR Is Nothing Then
        Col1 = Col1 + 3
        Else
            Select Case Col
                Case "A"
                    sh1.Cells(X, 12) = sh2.Cells(RR.Row, Col1 + 1)
                    sh1.Cells(X, 13) = sh2.Cells(RR.Row, Col1 + 2)
                    Exit For
                Case "D"
                    sh1.Cells(X, 14) = sh2.Cells(RR.Row, Col1 + 1)
                    sh1.Cells(X, 15) = sh2.Cells(RR.Row, Col1 + 2)
                    Exit For
              Case "G"
'...............

Find con 10 indirizzi id
di nicola (utente non iscritto) data: 09/02/2015 15:26:30
Ciao Raffaele....il codice è quasi a puntino....Ho notato che c'e un piccolo problema.....

Nelle famose 10 colonne dove andiamo ad analizzare la presenza dell id....ci posso essere gli stessi codici...
Es Colonna A cod 10 Colonna D 10 Colonna AB 10...

Il codice inserisce solo il primo codice che trova e gli altri non li inserisce...ti allego l'esempio..pratico
di Raffaele_53 (utente non iscritto) data: 09/02/2015 17:30:34
penso che questo problema dovresti togliere Exit For, il codice analizzerà se esiste lo stesso codice in tutte le colonne
Find con 10 indirizzi id
di nicola (utente non iscritto) data: 09/02/2015 17:42:52
Ho provato a togliere exit for....ma purtroppo i dati sono incompleti....

Cosa puo essere ???
di Raffaele_53 (utente non iscritto) data: 09/02/2015 17:52:41
Mi correggo
Devi rimettere al posto di EXIT FOR la riga Col1 = Col1 + 3
Inoltre dovresti mettere sotto la riga --->Ur1 = sh1.Range("E" & sh1.Rows.Count).End(xlUp).Row
sh1.Range("L3:AE" & Ur1).ClearContents ' cancella tutti i dati presenti

Ti ricordo che i dati in Db_miglior_promo.xlsm devono inziare dalla riga2

Find con 10 indirizzi id
di nicola (utente non iscritto) data: 10/02/2015 14:33:23
Grazieeee Raffaele ......Il codice funziona alla grandeee......E sono riuscito a capire i vari cicli + il select case....Complimenti e grazie per avermi sostenuto in questo nuovo codice....Grazie

Un grazie anche A Vecchio Frac....

;

Sotto il codice completo.....

A presto e al mio prossimo progetto(((A breve)))

Option Explicit
Sub ricerca()
Dim wb1 As Workbook: Set wb1 = ThisWorkbook
Dim sh1 As Worksheet: Set sh1 = wb1.Worksheets("Db_buyer")
Dim Area As Range, RR As Range
Dim Ur1 As Long, Ur2 As Long, Y As Long, X As Long, Col1 As Long, Col2 As Long, Col3 As Long
Dim ID As String, percorso As String, nomeFile As String
Dim Col As String
Application.ScreenUpdating = False
Application.EnableEvents = False

Ur1 = sh1.Range("E" & sh1.Rows.Count).End(xlUp).Row
sh1.Range("L3:AE" & Ur1).ClearContents
percorso = "C:Users
icola.spanuDesktopDb_miglior_promo_loc.xlsm"
Dim wb2 As Workbook: Set wb2 = Application.Workbooks.Open(percorso) ' da cambiare casomai
Dim sh2 As Worksheet: Set sh2 = wb2.Worksheets("Promo_buyer") ' da cambiare casomai
For X = 3 To Ur1
Col1 = 1
ID = sh1.Cells(X, 5).Value
    For Y = 1 To 10
        Col = LettCol(Col1)
        Ur2 = sh2.Range(Col & sh2.Rows.Count).End(xlUp).Row
        Set RR = sh2.Range(sh2.Cells(1, Col1), sh2.Cells(Ur2, Col1)).Find(ID, LookIn:=xlValues) ' non c'è bisogno di fare SET AREA
        If RR Is Nothing Then
        Col1 = Col1 + 3
        Else
            Select Case Col
                Case "A"
                    sh1.Cells(X, 12) = sh2.Cells(RR.Row, Col1 + 1)
                    sh1.Cells(X, 13) = sh2.Cells(RR.Row, Col1 + 2)
                   Col1 = Col1 + 3
                Case "D"
                    sh1.Cells(X, 14) = sh2.Cells(RR.Row, Col1 + 1)
                    sh1.Cells(X, 15) = sh2.Cells(RR.Row, Col1 + 2)
                    Col1 = Col1 + 3
              Case "G"
                    sh1.Cells(X, 16) = sh2.Cells(RR.Row, Col1 + 1)
                    sh1.Cells(X, 17) = sh2.Cells(RR.Row, Col1 + 2)
                    Col1 = Col1 + 3
               Case "J"
                    sh1.Cells(X, 18) = sh2.Cells(RR.Row, Col1 + 1)
                    sh1.Cells(X, 19) = sh2.Cells(RR.Row, Col1 + 2)
                    Col1 = Col1 + 3
                   
               Case "M"
                    sh1.Cells(X, 20) = sh2.Cells(RR.Row, Col1 + 1)
                    sh1.Cells(X, 21) = sh2.Cells(RR.Row, Col1 + 2)
                   Col1 = Col1 + 3
               Case "P"
                    sh1.Cells(X, 22) = sh2.Cells(RR.Row, Col1 + 1)
                    sh1.Cells(X, 23) = sh2.Cells(RR.Row, Col1 + 2)
                   Col1 = Col1 + 3
               Case "S"
                    sh1.Cells(X, 24) = sh2.Cells(RR.Row, Col1 + 1)
                    sh1.Cells(X, 25) = sh2.Cells(RR.Row, Col1 + 2)
                    Col1 = Col1 + 3
               Case "V"
                    sh1.Cells(X, 26) = sh2.Cells(RR.Row, Col1 + 1)
                    sh1.Cells(X, 27) = sh2.Cells(RR.Row, Col1 + 2)
                    Col1 = Col1 + 3
               Case "Y"
                    sh1.Cells(X, 28) = sh2.Cells(RR.Row, Col1 + 1)
                    sh1.Cells(X, 29) = sh2.Cells(RR.Row, Col1 + 2)
                    Col1 = Col1 + 3
               Case "AB"
                    sh1.Cells(X, 30) = sh2.Cells(RR.Row, Col1 + 1)
                    sh1.Cells(X, 31) = sh2.Cells(RR.Row, Col1 + 2)
                    Col1 = Col1 + 3
                    End Select
        End If
    Next Y
Next X
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = False
wb2.Close SaveChanges:=True
Application.DisplayAlerts = True
MsgBox "Aggiornamento eseguito con successo"
Set sh1 = Nothing
Set wb1 = Nothing
Set sh2 = Nothing
Set wb2 = Nothing
Set RR = Nothing
End Sub

Public Function LettCol(ByVal n As Long) As String 'By Scossa da inserire in un modulo
  LettCol = Replace(Cells(1, n).Address(False, False), "1", "")
End Function

di Vecchio Frac data: 10/02/2015 14:44:37
Bravo Nicola! Sono contento
di Vecchio Frac data: 10/02/2015 14:45:25
E anche bravo Raffaele naturalmente... non dimentichiamo nessuno :)

Vuoi Approfondire?