copia celle adiacenti da tre fogli

[Gianca532011]

Ciao, non riesco a venire a capo di questo banale problema . In pratica ho 4 fogli, Il primo "Destinazione " che reca dei codici univoci in E8:E da ricercare su altri tre fogli, sempre in colonna E8 e seguenti . Nota i codici di confronto sono 6 nel foglio Destinazione ma possono anche essere meno o piu negli altri 3 fogli da cui importare le celle F:i , stessa riga del codice di confronto .

Ho imbastito questa macro che però mi riporta sempre e solo un valore .

Codice: Seleziona tutto

Option Explicit

Sub Ricerca()
    Dim Ur1, Ur2 As Integer, X As Integer, Z As Integer
    Dim ws As Worksheet
    Dim Ws1 As Worksheet
   
    Application.ScreenUpdating = False
   
   Set Ws1 = Sheets("Destinazione")    '<<<  fo di destinazione + Elenco di ricerca
    Ur1 = Ws1.Cells(Rows.Count, 5).End(xlUp).Row  ' col. con i riferimenti  su ws1
    '
    Ws1.Range("F8:J" & Ur1).ClearContents
   
   For Each ws In ThisWorkbook.Worksheets
        Ur2 = ws.Cells(Rows.Count, 5).End(xlUp).Row
       If ws.Name <> "Destinazione" Then
            For X = 8 To Ur1    ' riga di partenza su foglio origine
                For Z = 8 To Ur2     ' idem su ws = altri fogli
                    If Ws1.Cells(X, 5) = ws.Cells(Z, 5) Then   ' cerca uguaglianza tra i codici di riferimento  ,
                        ' se trova uguaglianza copia le celle , stssa riga, a partire dalla col. successiva x 5 colonne
                         ws.Cells(X, 6).Resize(, 4).Copy Destination:=Ws1.Cells(X, 6) 'copia riga corrispondente
                       End If
                Next Z
            Next X
       End If
    Next ws

    Application.ScreenUpdating = True
    Set Ws1 = Nothing

End Sub


se serve aggiungo il file test.

[Raffaele53]

Fino 32.000 puoi usare Integer, per evitare errori futuri usa Long
Aggiungi la variabile >>>Dim R as Long
Valorizzala con R = 8
Modifica >>> ws.Cells(X, 6).Resize(, 4).Copy Destination:=Ws1.Cells(>>>R<<<, 6)
e subito sotto aggiungi R = R + 1

[Gianca532011]

Ciao Raffaele ,fatte le modifiche ma funziona solo per la colonna I , ho il dubbio che manchi anche una scansione per colonne , ovvero dalla f alla J . Aggiungo il file test cosi vedi meglio la situazione .


https://limewire.com/d/lGQV6#yNokkJQ8lF

[Raffaele53]

Ok con l'allegato si capisce meglio.
Tu desideri le corrispondenze dei tre fogli, era giusto se la corrispondenza fosse stata una sola (mà possono essere due/tre).
Ex 123456 è presente in 01.xlsx ed 02.xlsx
Pertanto in Destinazione servirebbero almeno altre due colonne, una per la matricola ed una per il foglio. Oppure in Destinazione copy colonne F:J e incolli in M1 ed S1, in teoria F:J per 01.xlsx, M:Q per 02.xlsx ed S:W per 03.xlsx

Casomai spiega meglio

[Gianca532011]

Si, in pratica per ogni matricola di cui al foglio primario = Destinazione la macro deve riportare le 5 celle corrispondenti alla stessa matricola , rispettivamente presenti su fo1, fo2, fo3 .

[Gianca532011]

vedi immagine , nota bene mi sono pure accorto che esiste sovrapposizione , quindi la copia dovrà essere cella su cella e non per range.

[Raffaele53]

A me sembra sbagliato
La cella J9 del foglio2 color violetto, è stata spostata da F a C ???
Un domani che ci sono stesse celle colorate le perderai.

[Gianca532011]

Si la cella è stata spostata , il colore è solo per indicare il foglio di provenienza. Non interessa .

[Raffaele53]

Codice: Seleziona tutto

Option Explicit

Sub Ricerca2()
    Dim Ur1, Ur2 As Integer, X As Integer, Z As Integer, Y As Integer
    Dim Ws As Worksheet
    Dim Ws1 As Worksheet

    Application.ScreenUpdating = False
   
   Set Ws1 = Sheets("Destinazione") '<<<  fo di destinazione + Elenco di ricerca
    Ur1 = Ws1.Cells(Rows.Count, 5).End(xlUp).Row  ' col. con i riferimenti  su ws1
    If Ur1 > 7 Then Ws1.Range("F8:J" & Ur1).ClearContents
    Ws1.Range("F8:J" & Ur1).Interior.ColorIndex = xlNone

   For Each Ws In ThisWorkbook.Worksheets
        Ur2 = Ws.Cells(Rows.Count, 5).End(xlUp).Row
       If Ws.Name <> "Destinazione" Then
            For X = 8 To Ur1    ' riga di partenza su foglio origine  della matricola
                For Z = 8 To Ur2     ' idem su ws x altri fogli
                    If Ws1.Cells(X, 5) = Ws.Cells(Z, 5) Then   ' cerca uguaglianza tra i codici di riferimento  ,
                        If Application.CountIf(Ws.Range("F" & Z & ":J" & Z), ">0") > 0 Then
                            For Y = 6 To 10
                                If Ws.Cells(Z, Y) <> "" Then
                                    Ws.Cells(Z, Y).Copy Destination:=Ws1.Cells(X, Y)
                                End If
                            Next Y
                        End If
                    End If
                Next Z
            Next X
       End If
    Next Ws

    Application.ScreenUpdating = True
Set Ws1 = Nothing
Set Ws = Nothing
MsgBox "Fatto"
End Sub

[Gianca532011]

Grazie Raffaele ,funziona benissimo .
Ho visto che mi sono "perso" proprio sul finale, unica cosa che mi risulta ancora da assimilare è il

Codice: Seleziona tutto

If Application.CountIf(Ws.Range("F" & Z & ":J" & Z), ">0") > 0 Then

che se traduco bene è come dire se il range F:J in funzione della matgricola Z è > di 0 ...

[Raffaele53]

>>>come dire se il range F:J
Per risparmiare cicli, quando due Matricole sono uguali gli chiedo se le sue 5 celle sono valorizzate, se sono vuote risparmio 5 cicli.
A proposito ho dato per scontato che all'interno di queste 5 celle fossero numeri. Casomai fossero lettere dovrai usare
If Application.CountBlank(Ws.Range("F" & Z & ":J" & Z)) <> 5 Then