Discussion :

[amapacha]

Bonjour à tous,

J'ai besoin d'aide svp!
j'ai un classeur qui a beaucoup de lignes et copier cellule par cellule me prend beaucoup de temps.

J'aimerai avoir une macro qui va me permettre de copier en comparant. Par exemple sur la feuille1 il on trouve dans une cell ''6'', copie le cotenu de la 3eme cellule devant ''6'' et aller coller sur la feuille2 à la 7eme cellule devant ''6''.

Pareil pour tout ce qu'il sur la feuille1.
Qu'il le fasse jusqu'à la 5000ème ligne.

Voir le classeur pour mieux comprendre je sais que je me suis pas bien fait comprendre.

Aidez moi à avancer plus vite svp!!

Merci d'avance.

Classeur2.xlsx

[parmi]

Bonjour,

Voici un exemple simple

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub Transfert()
    Dim I As Long
    Dim Recherche As Range
 
    For I = 5 To 18 'modifier au besoin
        If Sheets("Feuil1").Range("K" & I) <> "" Then
            Set Recherche = Sheets("Feuil2").Range("K6:K32").Find(Sheets("Feuil1").Range("K" & I), LookIn:=xlValues, LookAt:=xlWhole)
            If Not Recherche Is Nothing Then
                Sheets("Feuil2").Range("R" & Recherche.Row) = Sheets("Feuil1").Range("N" & I)
            End If
        End If
    Next
    For I = 26 To 39 'modifier au besoin
        If Sheets("Feuil1").Range("K" & I) <> "" Then
            Set Recherche = Sheets("Feuil2").Range("K33:K59").Find(Sheets("Feuil1").Range("K" & I), LookIn:=xlValues, LookAt:=xlWhole)
            If Not Recherche Is Nothing Then
                Sheets("Feuil2").Range("R" & Recherche.Row) = Sheets("Feuil1").Range("N" & I)
            End If
        End If
    Next
End Sub

[amapacha]

ça marche, mais je trouve que le code sera un peu long. Parce que j'aurai au moins 125 partie à ecrire.
ça m'avance mais n'y a-t-il pas moyen de généraliser ça sur tout le classeur .?

[parmi]

Peut-être essayer ainsi ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub Transfert()
    Dim I As Long, J As Long, nbLignes As Long
    Dim Debut1 As Long, Fin1 As Long
    Dim Debut2 As Long, Fin2 As Long
    Dim Recherche As Range
 
    nbLignes = Sheets("Feuil1").Cells(Rows.Count, "K").End(xlUp).Row
 
    Debut1 = 5  'début de série sur Feuil1
    Debut2 = 6  'début de série sur Feuil2
 
    For J = Debut1 To nbLignes
        Fin1 = Sheets("Feuil1").Range("B" & J).Rows.MergeArea.Count + Debut1 - 1
        Fin2 = Sheets("Feuil2").Range("B" & J + 1).Rows.MergeArea.Count + Debut2 - 1
 
        For I = Debut1 To Fin1
            If Sheets("Feuil1").Range("K" & I) <> "" Then
                Set Recherche = Sheets("Feuil2").Range("K" & Debut2 + 1 & ":K" & Fin2 + 1).Find(Sheets("Feuil1").Range("K" & I), LookIn:=xlValues, LookAt:=xlWhole)
                If Not Recherche Is Nothing Then
                    Sheets("Feuil2").Range("R" & Recherche.Row) = Sheets("Feuil1").Range("N" & I)
                End If
            End If
        Next
 
        Debut1 = Fin1 + 1
        Debut2 = Fin2 + 1
    Next
End Sub

[amapacha]

Un gros merci!! ça marche à la perfection.