Copie conditionnée - VBA

Boujour à tous,

J'ai besoin d'un coup de main... je me suis perdu dans mon code et je suis en train de m'agacer dessus...

L'idée est que j'ai 2 onglets dans mon fichier qui ont une construction similaire (même colonnes).

L'onglet "Suivi" permet de modifier manuellement les valeurs contenues tandis que l'onglet "Val" permet de synthétiser grâce à la fonction Index/Equiv d'autres tableau de données.

Bref, l'idée est que quand j'ai fini de modifier mes valeurs à la mano dans l'onglet "Suivi", j'active ma macro Extraire et je reporte les valeurs de certaines colonnes associées aux lignes répondant à la condition dans l'onglet "Val".

Condition (ligne à ligne) : Valeur de la ligne en colonne G de l'onglet "Suivi" = Valeur de la ligne en colonne G de l'onglet "Val", alors on reporte les valeurs associées et la mise en forme des colonnes Z, AC et AF à AH.

Voilà le code que j'ai démarré (je ne peux pas vous exporter le fichier...) mais arriver au moment de la condition, ça plante ...

Sub Extraire()
Application.ScreenUpdating = False
Dim tbSuivi(), tbVal()
Dim i!, j!

tbSuivi = Sheets("Val").Range("A1").CurrentRegion.Value2
tbVal = Sheets("Suivi").Range("A1").CurrentRegion.Value2
ReDim Preserve tbVal(1 To UBound(tbVal), 1 To UBound(tbVal, 2) + 1)
For i = 2 To UBound(tbVal)
For j = 2 To UBound(tbSuivi)
If tbVal(i, 7) = tbSuivi(j, 7) Then
'Copier la valeur et mise en forme de la colonne Z de la feuille "Suivi", de la ligne détectée grace à If dans la colonne Z de la feuille "Val" à la ligne détectée par If.
'Copier la valeur et mise en forme de la colonne AC de la feuille "Suivi", de la ligne détectée grace à If dans la colonne AC de la feuille "Val" à la ligne détectée par If.
'Copier la valeur et mise en forme des colonnes AF à AH de la feuille "Suivi", de la ligne détectée grace à If dans les colonnes AF à AH de la feuille "Val" à la ligne détectée par If.
End If
Next j
Next i

Application.ScreenUpdating = True
End Sub

Merci :)

Bonjour,

Ne manquerait-il pas une ligne du genre:

ReDim Preserve tbSuivi(1 To UBound(tbSuivi), 1 To UBound(tbSuivi, 2) + 1)

Cdlt

Salut Arturo !

Bien vu, mais je viens de l'ajouter et ça plante tout de même... Je comprends pas.

Peut-être faut-il que je recommence un nouveau code avec une nouvelle structure car je tourne en rond...

Ne serait-il pas possible d'avoir votre fichier (sans données confidentielles)?

Je fais un fichier test dans la soirée qui ressemblera au besoin et je le joindrai demain matin à la conversation 🙂.

Bonjour Arturo (et les autres qui suivent ce topic),

Comme convenu, ci-joint un fichier test succin.

J'ai du modifier mon onglet de stockage à cause de mon automatisation via la fonction IndexEquiv. Le report de données ne doit plus être vers l'onglet "Val" mais vers l'onglet "Ecart AS". Le code fourni avant est donc obsolète...

Donc, dans l'idée, lorsque j'actionne la macro "Extraire" celle-ci doit :

-> Comparer la valeur contenue dans la colonne G de l'onglet "Suivi" avec les valeurs contenues dans la colonne BX de l'onglet "Ecart AS".

-> Identifier la ligne ou i = j.

-> Reporter les valeurs des colonnes Z, AC et AF : AH de l'onglet "Suivi" vers les colonnes BY : CC de l'onglet "Ecart AS".

-> Boucle sur la ligne suivante.

Voilà :)

Si c'est pas clair, demandez moi.

Merci du coup de main.

Bonjour,

Votre macro modifiée

Option Explicit

Sub Extraire()
    Application.ScreenUpdating = False
    Dim i As Long, j As Long, Der_Suivi As Long, Der_Ecart_AS As Long
    Dim f1 As Worksheet, f2 As Worksheet

    Set f1 = Sheets("Suivi")
    Set f2 = Sheets("Ecart AS")
    Der_Suivi = f1.ListObjects("Tableau1").DataBodyRange.Rows.Count + 1
    Der_Ecart_AS = f2.ListObjects("Tableau2").DataBodyRange.Rows.Count + 1
    For i = 2 To Der_Ecart_AS
        For j = 2 To Der_Suivi
            If f1.Cells(j, "G") = f2.Cells(i, "BX") Then
                Range(f2.Cells(i, "BY"), f2.Cells(i, "CC")).Value = Array(f1.Cells(j, "Z"), f1.Cells(j, "AC"), f1.Cells(j, "AF"), f1.Cells(j, "AG"), f1.Cells(j, "AH"))
            End If
        Next j
    Next i

    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Le fichier( attention, les tableaux structurés ont été renommés)

Le fichier est enregistré au format .Xlsm, (comment se fait-il d'ailleurs, que vous enregistriez toujours en .xls?)

Cdlt

Super, merci Arturo.

Je vais tester cela.

Bonjour Arturo,

Désolé, j'ai réactivé le topic car je n'ai pas réussi à intégrer une mise à jour à ton code.

En effet, quand la cellule de départ est vide, ça me colle un zéro dans toutes les cellules de destination.

Est-ce possible de mettre un critère pour mettre une cellule vide au lieu d'un zéro stp ?

Merci.

Bonjour,

Essayez celui-ci:

Option Explicit

Sub Extraire()
    Application.ScreenUpdating = False
    Dim i As Long, j As Long, Der_Suivi As Long, Der_Ecart_AS As Long
    Dim f1 As Worksheet, f2 As Worksheet

    Set f1 = Sheets("Suivi")
    Set f2 = Sheets("Ecart AS")
    Der_Suivi = f1.ListObjects("Tableau1").DataBodyRange.Rows.Count + 1
    Der_Ecart_AS = f2.ListObjects("Tableau2").DataBodyRange.Rows.Count + 1
    For i = 2 To Der_Ecart_AS
        For j = 2 To Der_Suivi
            If f1.Cells(j, "G") = f2.Cells(i, "BX") And f2.Cells(i, "BX") <> "" or f1.Cells(j, "G") <> "" Then
                Range(f2.Cells(i, "BY"), f2.Cells(i, "CC")).Value = Array(f1.Cells(j, "Z"), f1.Cells(j, "AC"), f1.Cells(j, "AF"), f1.Cells(j, "AG"), f1.Cells(j, "AH"))
            End If
        Next j
    Next i

    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Cdlt

Le test est incertain...

2 fois que je lance la macro et 2 fois qu'elle me fait planter l'ordi (pas un ordi de compétition...)...

Pas moyen de l'alléger ? Tu utilises la fonction Data.Body, une fonction Value classique ne pourrait pas l'alléger ?

DataBodyRange est une syntaxe attribuée aux tableaux structurés.

Le problème vient sûrement que vos noms de tableaux structurés sont différents de ceux indiqués dans le code. J'avais préciser à la fin de mon 3ème post que j'avais renommé ces tableaux structurés, j'avais mis "Tableau1" pour la feuille "Suivi" et "Tableau2" pour la feuille Ecart AS". Avez-vous les bons noms?

Oui, je les avais renommé.

J'ai trouvé un moyen détourné d'obtenir le retrait des zéro (avec une fonction SI intégrée dans mon Index/Equiv).

C'est réglé ! :)