ceer une macro pour rechercher des données, les coller dans une autre feuille

[bensalme2012]

svp aider moi a créer une macro qui permet :
en cliquant sur le bouton ok
le code execute une recherche de chaque valeur des cellule de la plage feuil1!E:E dans la plage
feuil2!d:d
pour chaque valeur trouvée le code copiera les données en rouge corespondantes dans
l'une des zones jaune , orange ou verte de la feuille "feuil2" selon la date (feuil1!c2 )

voir les 2 feuilles au fichier joint
merci
​

 

[Robert]

Re : ceer une macro pour rechercher des données, les coller dans une autre feuille

Bonjour Bensalme et bienvenu, bonjour le forum,

En pièce jointe ton fichier modifié avec le code ci-desous :

Sub Macro1()
'*************************
'déclaration des variables
'*************************
Dim o1 As Object 'déclare la variable o1 (Onglet Feuil1)
Dim o2 As Object 'déclare la variable o2 (Onglet Feuil2)
Dim dl1 As Integer 'déclare la variable dl1 (Dernière Ligne de l'onglet feuil1)
Dim dl2 As Integer 'déclare la variable dl2 (Dernière Ligne de l'onglet feuil2)
Dim pl1 As Range 'déclare la variable pl1 (PLage 1)
Dim pl2 As Range 'déclare la variable pl2 (PLage 2)
Dim col As Byte 'déclare la variable col (COLonne)
Dim i As Byte 'décalre la variable i (Incrément)
Dim cel As Range 'déclare la variable cel (CELlule)
Dim li As Integer 'déclare la variable li (LIgne)

'********************************
'définition des plages de travail
'********************************
Set o1 = Sheets("Feuil1") 'définit l'onglet o1
Set o2 = Sheets("Feuil2") 'définit l'onglet o2
dl1 = o1.Cells(Application.Rows.Count, 5).End(xlUp).Row 'définit la dernière ligné éditée de la colonne 5 (=E) de l'onglet o1
Set pl1 = o1.Range("E4:E" & dl1) 'définit la plage pl1
dl2 = o2.Cells(Application.Rows.Count, 3).End(xlUp).Row 'définit la dernière ligné éditée de la colonne 3 (=D) de l'onglet o2
Set pl2 = o2.Range("D4:D" & dl2) 'définit la plage pl2
On Error Resume Next 'gestion des erreurs (passe à la ligne suivante si un erreur est rencontrée)
col = o2.Rows(2).Find(o1.Range("C2"), , xlFormulas, xlWhole).Column 'définit la colonne col (génère une erreur si date non trouvée)
If Err <> 0 Then 'condition : si une erreur a été générée
    Err = 0 'annnule l'erreur
    MsgBox "Date :" & o1.Range("C2").Value & " non trouvée !" 'message
    Exit Sub 'sort de la procédure
End If 'fin de la condition
On Error GoTo 0 'annulke la gestion des erreurs

'********************************
'effacement des anciennes données
'********************************
For i = 1 To 9 Step 4 'boucle sur les trois plages de couleur
    With pl2.Offset(0, i).Resize(pl2.Rows.Count, 4) 'prend en compte la plage
        .ClearContents 'efface le contenu
        .Interior.ColorIndex = o2.Cells(2, i + 4).Interior.ColorIndex 'remet la couleur initiale
    End With 'fin de la prose en compte de la plge
Next i 'prochaine plage

'*****************
'copie des données
'*****************
For Each cel In pl1 'boucles sur toutes les cellules de la plage pl1
    On Error Resume Next 'gestion des erreurs (passe à la ligne suivante si un erreur est rencontrée)
    li = pl2.Find(cel.Value, , xlValues, xlWhole).Row 'définit la ligne li (génère une erreur si la valeur n'est pas trouvée)
    If Err <> 0 Then Err = 0: GoTo suite 'si une erreur est générée, annnule l'erreur, va à l'etiquette "suite"
    cel.Offset(0, 1).Resize(, 4).Copy o2.Cells(li, col) 'récupère les valeurs
suite: 'étiqette
    On Error GoTo 0 'annule la gestion des erreurs
Next cel 'prochaine cellule de la boucle
End Sub

Le fichier :

 

[bensalme2012]

Re : ceer une macro pour rechercher des données, les coller dans une autre feuille

merci beaucoup mrs robert
entrain d'essayer votre propsition

 

[bensalme2012]

Re : ceer une macro pour rechercher des données, les coller dans une autre feuille

veuillez m'excuser mr robert
je veux conserver la couleur de chaque plage colorée apres la copie des données
quelle modification nécessaire pour le code que vous m'avez proposé suivant:

'copie des données
'*****************
For Each cel In pl1 'boucles sur toutes les cellules de la plage pl1
On Error Resume Next 'gestion des erreurs (passe à la ligne suivante si un erreur est rencontrée)
li = pl2.Find(cel.Value, , xlValues, xlWhole).Row 'définit la ligne li (génère une erreur si la valeur n'est pas trouvée)
If Err <> 0 Then Err = 0: GoTo suite 'si une erreur est générée, annnule l'erreur, va à l'etiquette "suite"
cel.Offset(0, 1).Resize(, 4).Copy o2.Cells(li, col) 'récupère les valeurs
suite: 'étiqette
On Error GoTo 0 'annule la gestion des erreurs
Next cel 'prochaine cellule de la boucle

merci

 

[Robert]

Re : ceer une macro pour rechercher des données, les coller dans une autre feuille

Bonsoir Bensalme, bonsoir le forum,

le code modifié :

Sub Macro1()

'*************************
'déclaration des variables
'*************************
Dim o1 As Object 'déclare la variable o1 (Onglet Feuil1)
Dim o2 As Object 'déclare la variable o2 (Onglet Feuil2)
Dim dl1 As Integer 'déclare la variable dl1 (Dernière Ligne de l'onglet feuil1)
Dim dl2 As Integer 'déclare la variable dl2 (Dernière Ligne de l'onglet feuil2)
Dim pl1 As Range 'déclare la variable pl1 (PLage 1)
Dim pl2 As Range 'déclare la variable pl2 (PLage 2)
Dim col As Byte 'déclare la variable col (COLonne)
Dim i As Byte 'déclare la variable i (Incrément)
Dim cel As Range 'déclare la variable cel (CELlule)
Dim li As Integer 'déclare la variable li (LIgne)

'********************************
'définition des plages de travail
'********************************
Set o1 = Sheets("Feuil1") 'définit l'onglet o1
Set o2 = Sheets("Feuil2") 'définit l'onglet o2
dl1 = o1.Cells(Application.Rows.Count, 5).End(xlUp).Row 'définit la dernière ligné éditée de la colonne 5 (=E) de l'onglet o1
Set pl1 = o1.Range("E4:E" & dl1) 'définit la plage pl1
dl2 = o2.Cells(Application.Rows.Count, 3).End(xlUp).Row 'définit la dernière ligné éditée de la colonne 3 (=D) de l'onglet o2
Set pl2 = o2.Range("D4:D" & dl2) 'définit la plage pl2
On Error Resume Next 'gestion des erreurs (passe à la ligne suivante si un erreur est rencontrée)
col = o2.Rows(2).Find(o1.Range("C2"), , xlFormulas, xlWhole).Column 'définit la colonne col (génère une erreur si date non trouvée)
If Err <> 0 Then 'condition : si une erreur a été générée
    Err = 0 'annnule l'erreur
    MsgBox "Date :" & o1.Range("C2").Value & " non trouvée !" 'message
    Exit Sub 'sort de la procédure
End If 'fin de la condition
On Error GoTo 0 'annulke la gestion des erreurs

'********************************
'effacement des anciennes données
'********************************
pl2.Offset(0, 1).Resize(pl2.Rows.Count, 12).ClearContents 'efface le contenu des anciennes données

'*****************
'copie des données
'*****************
Application.ScreenUpdating = False 'masques les changements à l écran
For Each cel In pl1 'boucles sur toutes les cellules de la plage pl1
    On Error Resume Next 'gestion des erreurs (passe à la ligne suivante si un erreur est rencontrée)
    li = pl2.Find(cel.Value, , xlValues, xlWhole).Row 'définit la ligne li (génère une erreur si la valeur n'est pas trouvée)
    If Err <> 0 Then Err = 0: GoTo suite 'si une erreur est générée, annnule l'erreur, va à l'etiquette "suite"
    cel.Offset(0, 1).Resize(, 4).Copy
    o2.Cells(li, col).PasteSpecial (xlPasteValues) 'récupère les valeurs
suite: 'étiqette
    On Error GoTo 0 'annule la gestion des erreurs
Next cel 'prochaine cellule de la boucle
Application.ScreenUpdating = True 'affiche les changements à l écran
End Sub