XL 2010 Copier-Coller valeurs d'un tableau à un autre (Résolu)

[Kael_88]

Le Forum,

pour continuer mon apprentissage, je cherche à remplir deux colonne dans un tableau,
explication dans fichier joint (plus facile à expliquer).

et si pas trop demander, mettre les commentaires afin que je comprenne,merci.

Cordialement

 

[Nairolf]

Salut,

Essaye avec le code suivant :

Sub Num_Article()

Dim NbValData As Integer
Dim NbValChange As Integer
Dim i As Integer
Dim j As Integer
Dim ValCh()
Dim ValComp()
Dim ValACopier1()
Dim ValACopier2()
Dim ValRetour1()
Dim ValRetour2()

NbValData = Application.WorksheetFunction.CountA(Worksheets("Data").Range("D:D")) - 1 'décompte du nombre de lignes dans l'onglet Data
NbValChange = Application.WorksheetFunction.CountA(Worksheets("Change").Range("B:B")) - 1 'décompte du nombre de lignes dans l'onglet Change

ValCh = Worksheets("Change").Range("B2", "B" & NbValChange + 1).Value 'valeurs cherchées
ValComp = Worksheets("Data").Range("D2", "D" & NbValData + 1).Value 'valeurs à comparer
ValACopier1 = Worksheets("Data").Range("A2", "A" & NbValData + 1).Value 'tableau intermédiaire valeurs à copier
ValACopier2 = Worksheets("Data").Range("E2", "E" & NbValData + 1).Value 'tableau intermédiaire valeurs à copier
ReDim ValRetour1(1 To NbValChange) 'dimensionnement du tableau de retour
ReDim ValRetour2(1 To NbValChange) 'dimensionnement du tableau de retour

For i = 1 To NbValChange 'boucle sur les lignes de l'onglet Change
    compt1 = 0 'compteur nombre de valeurs identiques à la valeur cherchée
    ValRetour1(i) = "" 'initialisation de la valeur de retour
    For j = 1 To NbValData 'boucle sur les lignes de l'onglet Data
        If Application.Index(ValCh, i, 1) = Application.Index(ValComp, j, 1) Then 'comparaison des valeurs
            If compt1 > 0 Then 'vérif état du compteur
                ValRetour1(i) = ValRetour1(i) & "-" 'ajout du séparateur
            End If
            ValRetour1(i) = ValRetour1(i) & Application.Index(ValACopier1, j, 1) 'ajout de la valeur à copier dans le tableau intermédiaire
            compt1 = compt1 + 1 'incrémentation compteur
            ValRetour2(i) = Application.Index(ValACopier2, j, 1)
        End If
    Next j
    Worksheets("Change").Range("A" & i + 1) = ValRetour1(i) 'ajout de la valeur à copier dans A
    Worksheets("Change").Range("I" & i + 1) = ValRetour2(i) 'ajout de la valeur à copier dans I
Next i

End Sub

 

[Kael_88]

Le forum ,Nairolf ,

Merci de ta réactivité, je viens d'adapter ton code sur mon fichier ,c'est génial ,fonctionne parfaitement.

petit bémol : mon Onglet "Data" comporte actuellement plus de 50 000 lignes en constante évolution ,Ça rame pendant environ 4 min, y aurait il moyen de réduire ce temps.

Merci encore pour ton aide

Cordialement

 

[job75]

Bonsoir Kael_88, Nairolf,

Pour aller vite il faut utiliser des tableaux VBA et des objets Dictionary :

Sub Remplissage()
Dim t, d1 As Object, d2 As Object, i&, x$, y$
t = Sheets("Data").[A1].CurrentRegion.Resize(, 9)
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
    x = t(i, 1): y = t(i, 4)
    If x <> "" Then
        If d1.exists(y) Then
            d1(y) = d1(y) & "-" & x
        Else
            d1(y) = x
        End If
    End If
    d2(y) = t(i, 5)
Next
With Sheets("Change").[A1].CurrentRegion.Resize(, 9)
    t = .Value
    For i = 2 To UBound(t)
        x = t(i, 2): t(i, 1) = d1(x): t(i, 9) = d2(x)
    Next
    If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
    .Columns(1) = Application.Index(t, , 1)
    .Columns(9) = Application.Index(t, , 9)
End With
End Sub

Edit : petit pinaillage au cas où la feuille est filtrée.

A+

 

[Kael_88]

Le forum, Nairolf, Job75,

Merci, je viens d'adapter ton code sur mon fichier, rien ne se passe, peux tu me mettre des commentaires comme l'avait fait Nairolf, stp,

afin que je comprenne le fonctionnement.

Merci encore pour votre aide

Cordialement

 

[job75]

Re,

Je viens de corriger une petite erreur dans mon code précédent.

S'agissant de tableaux VBA il n'y a pas à faire de commentaires.

Il faut savoir ce que c'est et connaître les Dictionary, un point c'est tout, nombreux exemples sur le forum.

Normalement mon code n'a pas besoin d'être adapté sauf si vous changez le nom des feuilles ou l'ordre des colonnes.

A+

 

[Kael_88]

Le forum, Nairolf, Job75,

Merci, je viens d'adapter ton code sur le fichier joint en haut et cela fonctionne, les commentaires demandés sont juste pour ma formation personnel, et aussi pour pouvoir adapter à mon fichier ou, justement le nom des feuilles changent(là pas de problème), mais je ne sais pas ou retrouver les colonne pour la recherche, celle de la copie, et celle du collage?
donc j'essaye à taton.

Dsl de ne pas tout connaitre, mais je suis débutant en programmation VBA, et c'est justement avec ces petits commentaires que j'arrive à apprendre.

Merci encore pour l'aide.

Cordialement

 

[job75]

Re,

Pour l'ordre des colonnes pourquoi ne pas avoir déposé un fichier avec le bon ordre ???

A+

 

[Kael_88]

Re,

Afin d'apprendre et pouvoir m'en resservir si besoin.

pour indication sur mon fichier :

1- je recherche similitude valeur colonne B de la feuille "Chance" avec la colonne F de la feuille "Data", si correspondance, reporter les valeurs de la colonne E de la feuille "Data" dans la colonne A de la feuille "Chance" et si plusieurs valeur les mettre dans la même case avec un "-"pour les séparer,

2- je recherche similitude valeur colonne E de la feuille "Chance" avec la colonne F de la feuille "Data", si correspondance, reporter les valeurs de la colonne E de la feuille "Data" dans la colonne I de la feuille "Chance" et si plusieurs valeur ne mettre que la dernière.

La maîtrise du codage est le début de la connaissance & la connaissance est la clé du savoir.

Cordialement

 

[job75]

Bonjour Kael_88, le forum,

1- ...si correspondance, reporter les valeurs de la colonne E de la feuille "Data" dans la colonne A de la feuille "Chance"

2- ...si correspondance, reporter les valeurs de la colonne E de la feuille "Data" dans la colonne I de la feuille "Chance"

Cela ne paraît pas bien cohérent de reporter 2 fois les valeurs de la même colonne.

Joignez votre fichier, allégé bien sûr (une vingtaine de lignes suffisent).

Bonne journée.

 

[Kael_88]

Le forum, Nairolf, Job75,

Merci de ton attention,

oui en effet, je viens de m'apercevoir qu'il y a une erreur sur des lettres des colonnes dans ma dernière explication.

je joint le fichier avec l'ordre exact des colonnes et les explications correct sur leur fonctionnement.

Merci encore pour l'aide.

Cordialement

 

[job75]

Re,

Sub Remplissage()
Dim t, d1 As Object, d2 As Object, i&, x$, y$
t = Sheets("Data").[A1].CurrentRegion.Resize(, 9)
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
    x = t(i, 5): y = t(i, 6)
    If x <> "" And x <> "Vide" Then
        If d1.exists(y) Then
            d1(y) = d1(y) & "-" & x
        Else
            d1(y) = x
        End If
        d2(t(i, 8)) = x
    End If
Next
With Sheets("Change").[A1].CurrentRegion.Resize(, 9)
    t = .Value
    For i = 2 To UBound(t)
        t(i, 1) = d1(t(i, 2)): t(i, 9) = d2(t(i, 5))
    Next
    If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
    .Columns(1) = Application.Index(t, , 1)
    .Columns(9) = Application.Index(t, , 9)
End With
End Sub

A+

 

[Kael_88]

Le forum, Nairolf, Job75,

Merci pour ton nouveau programme, je l'ai copié dans mon fichier original, pour la colonne A pas de soucis pour le renvoi c'est ok, pour la colonne I par contre j'ai un soucis,

la suppression de "Vide" se fait dans colonne A .(résolu j'ai retiré [And x<>"Vide"] de la ligne)

comment faire pour que si en I la dernière valeur est "Vide" mettre la valeur précédente.

Merci encore pour l'aide.

Cordialement

 

[job75]

Re,

J'espère que c'est la dernière :

Sub Remplissage()
Dim t, d1 As Object, d2 As Object, i&, x$, y$
t = Sheets("Data").[A1].CurrentRegion.Resize(, 9)
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
    x = t(i, 5): y = t(i, 6)
    If x <> "" Then
        If d1.exists(y) Then
            d1(y) = d1(y) & "-" & x
        Else
            d1(y) = x
        End If
        If x <> "Vide" Then d2(t(i, 8)) = x
    End If
Next
With Sheets("Change").[A1].CurrentRegion.Resize(, 9)
    t = .Value
    For i = 2 To UBound(t)
        t(i, 1) = d1(t(i, 2)): t(i, 9) = d2(t(i, 5))
    Next
    If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
    .Columns(1) = Application.Index(t, , 1)
    .Columns(9) = Application.Index(t, , 9)
End With
End Sub

A+

 

[Kael_88]

Le forum, Nairolf, Job75,

Merci de ta modif aussi rapide,

c'est parfait et ça fonctionne nickel (en plus c'est rapide),

Merci encore pour l'aide (problème résolu).

Cordialement