XL 2019 VBA - Condition et copie en valeur

xbooster

XLDnaute Nouveau
Je viens ne parvient pas à ressoudre mon problème et vu de mon faible niveau en VBA.

Ce que je voudrais c'est que la Macro recherche la date et le nom qui se trouve dans l'onglet Extra et qui s'il trouve le nom et la date correspondante dans l'onglet BDD il colle en valeur en colonne D les données qui se trouvent dans l'onglet EXTRA colonne C.

Je vous joins un fichier exemple il y a une macro que j'ai essayé de bidouiller pour arriver à mon résultat mais elle ne fonctionne pas très bien.

Un grand merci a tous pour votre aide

Cdt

Jérôme
 

Pièces jointes

  • TEST_CRITERE.xlsm
    16.7 KB · Affichages: 4

vgendron

XLDnaute Barbatruc
Bonjour

ci dessous une macro a mettre dans un module standard
VB:
Sub transferer()
Dim TabExtra() As Variant
Dim tabBDD() As Variant
With Sheets("EXTRA")
    fin = .Range("A" & .Rows.Count).End(xlUp).Row
    TabExtra = .Range("A2:C" & fin).Value
End With

With Sheets("BDD")
    fin = .Range("A" & .Rows.Count).End(xlUp).Row
    tabBDD = .Range("A2:D" & fin).Value
End With

For i = LBound(TabExtra, 1) To UBound(TabExtra, 1)
    For j = LBound(tabBDD, 1) To UBound(tabBDD, 1)
        If TabExtra(i, 1) = tabBDD(j, 1) And TabExtra(i, 2) = tabBDD(j, 2) Then 'on a une correspondance Date + nom
            tabBDD(j, 4) = TabExtra(i, 3) 'on copie la colonne C dans la colonne D
            Exit For
            
        End If
    Next j
Next i

With Sheets("BDD")
    .Range("A2").Resize(UBound(tabBDD, 1), UBound(tabBDD, 2)) = tabBDD
    
End With

End Sub
 

xbooster

XLDnaute Nouveau
Bonjour

ci dessous une macro a mettre dans un module standard
VB:
Sub transferer()
Dim TabExtra() As Variant
Dim tabBDD() As Variant
With Sheets("EXTRA")
    fin = .Range("A" & .Rows.Count).End(xlUp).Row
    TabExtra = .Range("A2:C" & fin).Value
End With

With Sheets("BDD")
    fin = .Range("A" & .Rows.Count).End(xlUp).Row
    tabBDD = .Range("A2:D" & fin).Value
End With

For i = LBound(TabExtra, 1) To UBound(TabExtra, 1)
    For j = LBound(tabBDD, 1) To UBound(tabBDD, 1)
        If TabExtra(i, 1) = tabBDD(j, 1) And TabExtra(i, 2) = tabBDD(j, 2) Then 'on a une correspondance Date + nom
            tabBDD(j, 4) = TabExtra(i, 3) 'on copie la colonne C dans la colonne D
            Exit For
           
        End If
    Next j
Next i

With Sheets("BDD")
    .Range("A2").Resize(UBound(tabBDD, 1), UBound(tabBDD, 2)) = tabBDD
   
End With

End Sub

Salut vgendron,

Ton code fonctionne tres bien juste une petite question comment ajouter d'autre colonne a copier si besoin s'il te plaît ?

merci bien

Cdt

Jérôme
 

vgendron

XLDnaute Barbatruc
il faut ajuster les tabExtra (colonnes A à C) et tabBdd (de A à D)
ci dessous le meme code avec des commentaires

VB:
Sub transferer()
Dim TabExtra() As Variant
Dim tabBDD() As Variant
With Sheets("EXTRA")
    fin = .Range("A" & .Rows.Count).End(xlUp).Row 'dernière ligne de la feuille
    TabExtra = .Range("A2:C" & fin).Value 'on met les colonnes A à C dans un tableau
End With

With Sheets("BDD")
    fin = .Range("A" & .Rows.Count).End(xlUp).Row 'dernière ligne de la feuille
    tabBDD = .Range("A2:D" & fin).Value 'on met les colonnes A à D dans un tableau
End With

For i = LBound(TabExtra, 1) To UBound(TabExtra, 1) 'pour chaque ligne du tablo
    For j = LBound(tabBDD, 1) To UBound(tabBDD, 1) 'pour chaque ligne du tablo
        If TabExtra(i, 1) = tabBDD(j, 1) And TabExtra(i, 2) = tabBDD(j, 2) Then 'on a une correspondance Date + nom
            tabBDD(j, 4) = TabExtra(i, 3) 'on copie la colonne C dans la colonne D
            Exit For 'pas besoin de continuer la boucle 'SAUF si la meme ligne peut apparaitre plusieurs fois??
           
        End If
    Next j
Next i

With Sheets("BDD")
    .Range("A2").Resize(UBound(tabBDD, 1), UBound(tabBDD, 2)) = tabBDD 'on colle le résultat
   
End With

End Sub
 

Discussions similaires

Réponses
6
Affichages
552

Membres actuellement en ligne

Statistiques des forums

Discussions
314 450
Messages
2 109 719
Membres
110 551
dernier inscrit
Khyolyanna