XL 2019 VBA - Condition et copie en valeur

xbooster · 1 Septembre 2021

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

vgendron · 1 Septembre 2021

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 · 1 Septembre 2021

vgendron à dit:

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 · 1 Septembre 2021

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

XL 2019 VBA - Condition et copie en valeur

xbooster

XLDnaute Nouveau

Pièces jointes

vgendron

XLDnaute Barbatruc

xbooster

XLDnaute Nouveau

vgendron

XLDnaute Barbatruc

Discussions similaires