XL 2021 Modification et remplacer l'origine

[achraf26]

Bonjour,
j'ai crée un tableau nommé résumé dont il y'a les informations recherché du tableau(x) original(aux), au final je voudrais savoir quel fonction ou vba qui me permet de modifier si nécessaire des informations affiché et les remplacer automatiquement à la ligne correspondante du tableau original.
Merci infiniment.

 

[sylvanu]

Bonjour Achraf,
Si j'ai bien compris un essai en VBA avec deux flèches :
- Chercher : Cherche le client demandé et remplace les données du tableau résumé avec ces valeurs.
-Mettre à jour : Met à jour le tableau principal avec les données modifiées du tableau résumé.

Sub Chercher()
    Client = [D3]
    [J8:P8].ClearContents
    NL = [Tableau1].ListObject.ListRows.Count
    For L = 1 To NL
        If [Tableau1].Item(L, 1) = Client Then
            For C = 1 To 7
                Cells(8, C + 9) = [Tableau1].Item(L, C)
            Next C
            Exit Sub
        End If
    Next L
End Sub
Sub MettreAjour()
    Client = [D3]
    NL = [Tableau1].ListObject.ListRows.Count
    For L = 1 To NL
        If [Tableau1].Item(L, 1) = Client Then
            For C = 1 To 7
                [Tableau1].Item(L, C) = Cells(8, C + 9)
            Next C
            Exit Sub
        End If
    Next L
End Sub

 

[achraf26]

Bonjour Achraf,
Si j'ai bien compris un essai en VBA avec deux flèches :
- Chercher : Cherche le client demandé et remplace les données du tableau résumé avec ces valeurs.
-Mettre à jour : Met à jour le tableau principal avec les données modifiées du tableau résumé.

Sub Chercher()
    Client = [D3]
    [J8:P8].ClearContents
    NL = [Tableau1].ListObject.ListRows.Count
    For L = 1 To NL
        If [Tableau1].Item(L, 1) = Client Then
            For C = 1 To 7
                Cells(8, C + 9) = [Tableau1].Item(L, C)
            Next C
            Exit Sub
        End If
    Next L
End Sub
Sub MettreAjour()
    Client = [D3]
    NL = [Tableau1].ListObject.ListRows.Count
    For L = 1 To NL
        If [Tableau1].Item(L, 1) = Client Then
            For C = 1 To 7
                [Tableau1].Item(L, C) = Cells(8, C + 9)
            Next C
            Exit Sub
        End If
    Next L
End Sub

Merci Sylvanu,
j'ai bien vu le code, pour le tableau 2 résumé il y'aura plusieurs lignes et pas seulement J8😛8 suite au filtre, qui correspond aux résultats de ma recherche, lors de la modification d'une ou plusieurs lignes la fonction se supprime du coup ce n'est pas évident.
NB un client peut avoir plusieurs résultats.

 

[sylvanu]

lors de la modification d'une ou plusieurs lignes la fonction se supprime du coup ce n'est pas évident.

S'il y a plusieurs lignes pour un même client, cela suppose qu'il n'y aura jamais de modification du nom de client dans le tableau résumé sinon on ne retrouvera pas l'origine de la ligne.
Est ce que la Numérotations sera unique dans le tableau ?
Ou Peux t-on ajouter dans le tableau résumé le N° de ligne correspondant?

Le problème est qu'on peut filtrer pour obtenir un tableau résumé, puis modifier en rajoutant des lignes dans le tableau principal, puis ensuite essayer de mettre à jour. Dans ce cas comment fait on pour savoir quelle ligne du tableau principal correspond à telle ligne du tableau résumé ?

 

[achraf26]

S'il y a plusieurs lignes pour un même client, cela suppose qu'il n'y aura jamais de modification du nom de client dans le tableau résumé sinon on ne retrouvera pas l'origine de la ligne.
Est ce que la Numérotations sera unique dans le tableau ?
Ou Peux t-on ajouter dans le tableau résumé le N° de ligne correspondant?

Le problème est qu'on peut filtrer pour obtenir un tableau résumé, puis modifier en rajoutant des lignes dans le tableau principal, puis ensuite essayer de mettre à jour. Dans ce cas comment fait on pour savoir quelle ligne du tableau principal correspond à telle ligne du tableau résumé ?

je pense que je vais mettre des numéros unique de ligne pour tous les tableaux afin de que la modification sera plus facile.
Nom : Tableau 1
Nom : Tableau 2 Etc.

exemple :
- numéro de lignes non répétitifs pour tous les tableaux. dans la 1er colonne (Tableau 1) je mettrai numérotation de la 1er ligne exemple 1, mais dans le (tableau 2) sa première ligne sera 2.

- tableau Résumé est toujours filtré
- nb : pour combiner les tableau : Assembl.V et non disponible sur office 21, du coup je dois trouver une autre solutions.

Merci Sylavanu

 

[sylvanu]

Re,
Effectivement ainsi chaque ligne est tagguée et la confusion entre deux lignes du même client est supprimée.
En PJ un essai avec les deux mêmes boutons que précédemment.

 

[achraf26]

Merci Sylvanu, tu m'as beaucoup aidé.

 

[job75]

Bonsoir achraf26, sylvanu,

Notez que pour la 1ère macro on peut utiliser le filtre automatique :

Sub Chercher()
    Dim Client, AC As Range
    Client = [U3]
    Set AC = ActiveCell
    Application.ScreenUpdating = False
    Range("T8:AA" & Rows.Count).ClearContents
    With [Tableau1].ListObject.Range
        .AutoFilter 2, Client
        .SpecialCells(xlCellTypeVisible).Copy
        [T7].PasteSpecial xlPasteValues
        .AutoFilter 2
    End With
    With [Tableau2].ListObject.Range
        .AutoFilter 2, Client
        .Offset(1).SpecialCells(xlCellTypeVisible).Copy
        [T7].Offset([T7].CurrentRegion.Rows.Count).PasteSpecial xlPasteValues
        .AutoFilter 2
    End With
    AC.Select
End Sub

C'est peut être plus rapide (à mesurer sur de grands tableaux).

A+

 

[job75]

J'ai testé en recopiant Tableau1 sur 60 000 lignes, chez moi sur Win 11 Excel 2019 :

- macro du post #6 => 21 secondes

- macro du post #8 => 1,9 seconde.

 

[achraf26]

J'ai testé en recopiant Tableau1 sur 60 000 lignes, chez moi sur Win 11 Excel 2019 :

- macro du post #6 => 21 secondes

- macro du post #8 => 1,9 seconde.

Bonsoir Merci à vous aussi job,
j'ai pris le post 8, fonctionne super rapide, je garde bien le bouton mettre à jour, mais pour le bouton chercher y'a moyen de l'enlever afin de gagner du temps, juste écrire le nom de la personne, appuyer sur Enter et sera un filtre automatique ?

 

[job75]

mais pour le bouton chercher y'a moyen de l'enlever afin de gagner du temps ?

Oui bien sûr, la macro dans le code de la feuille :

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$U$3" Then Exit Sub
    Target.Select
    Application.ScreenUpdating = False
    Range("T8:AA" & Rows.Count).ClearContents
    With [Tableau1].ListObject.Range
        .AutoFilter 2, Target
        .SpecialCells(xlCellTypeVisible).Copy
        [T7].PasteSpecial xlPasteValues
        .AutoFilter 2
    End With
    With [Tableau2].ListObject.Range
        .AutoFilter 2, Target
        .Offset(1).SpecialCells(xlCellTypeVisible).Copy
        [T7].Offset([T7].CurrentRegion.Rows.Count).PasteSpecial xlPasteValues
        .AutoFilter 2
    End With
    Target.Select
End Sub

Elle s'exécute quand on modifie ou valide la cellule U3.

 

[job75]

J'ai ajouté Target.Select au début de la macro, le visuel est meilleur.

 

[job75]

Bonjour le forum,

Avec cette version tous les tableaux structurés sont traités dans une boucle :

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$L$3" Then Exit Sub
    Dim dest As Range, LO As ListObject
    Target.Select
    Set dest = [K7]
    Application.ScreenUpdating = False
    dest.CurrentRegion.Offset(1).ClearContents 'RAZ
    For Each LO In Me.ListObjects 'traite tous les tableaux structurés
        With LO.Range
            .AutoFilter 2, Target
            .Offset(1).SpecialCells(xlCellTypeVisible).Copy
            dest.Offset(dest.CurrentRegion.Rows.Count).PasteSpecial xlPasteValues
            .AutoFilter 2
        End With
    Next LO
    Target.Select
End Sub

Quant à l'autre macro :

Sub MettreAjour()
Dim Lig&, Numéro, LO As ListObject, NL&, L&, C%
Lig = 8
While Cells(Lig, "K") <> ""
    Numéro = Cells(Lig, "K")
    For Each LO In ActiveSheet.ListObjects
        NL = LO.Range.Rows.Count
        For L = 2 To NL
            If LO.Range(L, 1) = Numéro Then
                For C = 1 To 8
                    LO.Range(L, C) = Cells(Lig, C + 10)
                Next C
            End If
    Next L, LO
    Lig = Lig + 1
Wend
End Sub

A+

 

[achraf26]

Bonjour Job & Sylv,
Merci pour votre solutions, j'ai appliqué les codes vba proposé, mais je n'arrive pas à résoudre la mise a jour, copier les données corrigés à leurs places origine.

 

[achraf26]

Bonjour Job & Sylv,
Merci pour votre solutions, j'ai appliqué les codes vba proposé, mais je n'arrive pas à résoudre la mise a jour, copier les données corrigés à leurs places origine.

Option Explicit

Sub MettreAjour()
Dim Lig&, L&, NL&, C%, Numéro
Lig = 8
While Cells(Lig, "AN") <> ""
    Numéro = Cells(Lig, "BU")
    NL = [Tableau4].ListObject.ListRows.Count
    For L = 1 To NL
        If [Tableau4].Item(L, 1) = Numéro Then
            For C = 1 To 14
                [Tableau1].Item(L, C) = Cells(Lig, C + 39)
            Next C
        End If
    Next L
    Lig = Lig + 1
Wend
End Sub