XL 2021 Modification et remplacer l'origine

  • Initiateur de la discussion Initiateur de la discussion achraf26
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

achraf26

XLDnaute Occasionnel
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.
 

Pièces jointes

Solution
Sur le fichier du post #17 la ligne AN6:AW6 n'était pas vide !!!

J'ai complété les lignes d'en-têtes des tableaux.

Les macros :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$AG$3" Then Exit Sub
    Dim dest As Range, LO As ListObject
    Target.Select
    Set dest = [AN7]
    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 7, Target
            .Offset(1).SpecialCells(xlCellTypeVisible).Copy
            dest.Offset(dest.CurrentRegion.Rows.Count).PasteSpecial xlPasteValues
            .AutoFilter 7
        End With
    Next LO
    Target.Select
End...
Bonjour achraf26,

Vous n'avez pas eu de réponse parce que le fichier déposé au post #14 est incohérent.

Pourquoi ne pas utiliser le code que j'ai donné au post #13 ?

A+

Bonjour Job,
merci pour votre réponse, j'ai pris le code de post 13, je l'ai appliqué ::
conclusion : les lignes recherché se met à partir de la 2é ligne du tableau, et lors d'une modification aucun changement n'est fais.
Merci.

VB:
Sub MettreAjour()
Dim Lig&, Numéro, LO As ListObject, NL&, L&, C%
Lig = 8
While Cells(Lig, "AN") <> ""
    Numéro = Cells(Lig, "AN")
    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 10
                    LO.Range(L, C) = Cells(Lig, C + 39)
                Next C
            End If
    Next L, LO
    Lig = Lig + 1
Wend
End Sub


Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$AG$3" Then Exit Sub
    Dim dest As Range, LO As ListObject
    Target.Select
    Set dest = [AN8]
    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 7, Target
            .Offset(1).SpecialCells(xlCellTypeVisible).Copy
            dest.Offset(dest.CurrentRegion.Rows.Count).PasteSpecial xlPasteValues
            .AutoFilter 7
        End With
    Next LO
    Target.Select
End Sub
 

Pièces jointes

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

Pièces jointes

Sur le fichier du post #17 la ligne AN6:AW6 n'était pas vide !!!

J'ai complété les lignes d'en-têtes des tableaux.

Les macros :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$AG$3" Then Exit Sub
    Dim dest As Range, LO As ListObject
    Target.Select
    Set dest = [AN7]
    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 7, Target
            .Offset(1).SpecialCells(xlCellTypeVisible).Copy
            dest.Offset(dest.CurrentRegion.Rows.Count).PasteSpecial xlPasteValues
            .AutoFilter 7
        End With
    Next LO
    Target.Select
End Sub
VB:
Sub MettreAjour()
Dim Lig&, Numéro, LO As ListObject, NL&, L&, C%
Lig = 8
While Cells(Lig, "AQ") <> ""
    Numéro = Cells(Lig, "AQ")
    For Each LO In ActiveSheet.ListObjects
        NL = LO.Range.Rows.Count
        For L = 2 To NL
            If LO.Range(L, 4) = Numéro Then
                For C = 1 To 10
                    LO.Range(L, C) = Cells(Lig, C + 39)
                Next C
            End If
    Next L, LO
    Lig = Lig + 1
Wend
End Sub
 

Pièces jointes

Sur le fichier du post #17 la ligne AN6:AW6 n'était pas vide !!!

J'ai complété les lignes d'en-têtes des tableaux.

Les macros :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$AG$3" Then Exit Sub
    Dim dest As Range, LO As ListObject
    Target.Select
    Set dest = [AN7]
    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 7, Target
            .Offset(1).SpecialCells(xlCellTypeVisible).Copy
            dest.Offset(dest.CurrentRegion.Rows.Count).PasteSpecial xlPasteValues
            .AutoFilter 7
        End With
    Next LO
    Target.Select
End Sub
VB:
Sub MettreAjour()
Dim Lig&, Numéro, LO As ListObject, NL&, L&, C%
Lig = 8
While Cells(Lig, "AQ") <> ""
    Numéro = Cells(Lig, "AQ")
    For Each LO In ActiveSheet.ListObjects
        NL = LO.Range.Rows.Count
        For L = 2 To NL
            If LO.Range(L, 4) = Numéro Then
                For C = 1 To 10
                    LO.Range(L, C) = Cells(Lig, C + 39)
                Next C
            End If
    Next L, LO
    Lig = Lig + 1
Wend
End Sub

Bonjour Job,
j'espère que vous allez bien, j'ai eu mon temps ce weekend pour avancer, j'avais rajouter un deuxième tableau que rien avoir avec le tableau4 déjà existant, le code recherche pour le tableau 4 ne fonctionne plus, ça beug au niveau de
VB:
.Offset(1).SpecialCells(xlCellTypeVisible).Copy
ci joint fichier exemple.
cordialement
 

Pièces jointes

Bonjour achraf26,

Non il y a bug sur :
VB:
.AutoFilter 7, Target
On filtre sur la 7ème colonne mais le 1er tableau structuré (Tableau1) n'était défini que sur 6 colonnes, je l'ai donc défini sur 7.

En W7 l'en-tête est constituée de 4 espaces, c'est vous qui les avez mis.

A+
 

Pièces jointes

Bonjour à toutes & à tous, bonjour @achraf26

Puisque tu disposes d'EXCEL2021 je te propose une solution avec les fonctionnalités disponibles dans cette version.

Pour régler le problème des Tableaux Structurés devant être traités ou non, j'ai ajouté une feuille "Tables" avec un TS listant les tableaux devant être pris en compte.
Les TS suivis sont sensés avoir la même structure, puisque leurs extraits sont concaténés dans le TS "TS_Résumé".
Sur cette même feuille, la liste des Noms des "Contractants" pour la validation de données de la cellule "NomCherché" (elle est mise à jour automatiquement et prend en compte tous les TS traités)
L'identification des colonnes concernées se fait par leur nom et non par leur position (les noms sont dans des constantes "Public" dans le code)
Il n'y a plus de bouton à cliquer, la mise à jour des TS suivis se fait suite à l'événement Worksheet_Change


VB:
Private Sub Worksheet_Change(ByVal Target As Range)
    
     Dim Cible As Range, Tb_TS, TS
    
     'Si modification du nom recherché
     If Target.Cells(1).Address = Me.Evaluate(Recherche).Address Then
          Application.EnableEvents = False
          Extraire
          Application.EnableEvents = True
          Exit Sub
     End If
    
     'Si modification du TS TS_Résumé
     Set Cible = Intersect(Target, Me.Evaluate(NomTSRésumé))
     If Not Cible Is Nothing Then
          Application.EnableEvents = False
          MàJ_TSlistes Cible
          Application.EnableEvents = True
          Exit Sub
     End If
    
     'Si modification dans les colonnes "Contractants" des TS suivis
     Tb_TS = Sh_Tables.[TS_NomsTS]
     For Each TS In Tb_TS
          Set ColNom = Me.Evaluate(TS & "[" & Nom & "]")
          Set Cible = Intersect(Target, ColNom.Resize(ColNom.Rows.Count + 1))
          If Not Cible Is Nothing Then
               MàJ_Liste_Contractants
               Exit Sub
          End If
     Next
    
End Sub
VB:
Public Const NomTSRésumé = "TS_Résumé"
Public Const Nom = "Contractants"
Public Const Recherche = "NomCherché"
Public Const Repère = "Col4"
'

'Extraire des TS suivis les enregistrements correspondant au nom recherché
Sub Extraire()
     Dim tb, TbGlob, Trans, Tb_TS, First As Boolean, No
     Dim Taille As Long, Taille1a As Long, Taille1b As Long, Taille2 As Long, i As Long, j As Long
     
     Tb_TS = Sh_Tables.[TS_NomsTS]
     
     If Evaluate(Recherche) = "" Then 'si effacement du nom recherché
          With [TS_Résumé]
               .ClearContents
               .ListObject.Resize .Offset(-1).Resize(2)
          End With
          Exit Sub
     End If
     
     First = True
     
     For Each TS In Tb_TS     'Parcourrir tous les tableaux à traiter
          
          'Mettre dans tb les lignes correspondant au nom recherché (dans la cellule "NomCherché" (constante Recherche))
          tb = Evaluate("LET(Lst,FILTER(" & TS & "," & TS & "[" & Nom & "]=" & Recherche & ",""""),IF(Lst="""","""",Lst))")
          
          If IsArray(tb) Then  '(il y a au moins une ligne filtrée)
               
               'Traitement pour le cas où l'on n'a qu'une ligne retournée (tb est un tableau à une dimension)
               On Error Resume Next: dd = UBound(tb, 2): No = Err.Number: On Error GoTo 0
               If No <> 0 Then
                    Taille = UBound(tb, 1)
                    ReDim Trans(1 To 1, 1 To Taille)
                    For i = 1 To Taille
                         Trans(1, i) = tb(i)
                    Next
                    tb = Trans
               End If
               'Tb est un tableau à 2 dimensions ...
               
               If First Then
                    TbGlob = tb: First = False    'Pour le 1er TS suivi
               Else                               'Pour les TS suivants
                    '(On aurait pu faire avec redim preserve puis transposer ... mais bon !)
                    Taille1a = UBound(TbGlob, 1)
                    Taille1b = UBound(tb, 1)
                    Taille2 = UBound(TbGlob, 2)
                    ReDim Trans(1 To Taille1a + Taille1b, 1 To Taille2)
                    'Reprise des valeurs déjà collectées
                    For i = 1 To Taille1a: For j = 1 To Taille2
                         Trans(i, j) = TbGlob(i, j)
                    Next j, i
                    'Ajout des nouvelles valeurs
                    For i = 1 To Taille1b: For j = 1 To Taille2
                         Trans(i + Taille1a, j) = tb(i, j)
                    Next j, i
                    TbGlob = Trans
               End If
          End If
     Next
     
     'Mise à jour du TS Cible (Constante NomTSRésumé)
     If IsEmpty(TbGlob) Then
          'Pas de données filtrées (le nom cherché ne matche pas)
          With [TS_Résumé]
               .ClearContents
               .ListObject.Resize .Offset(-1).Resize(2)
          End With
     Else
          'Coller les données collectées dans le "TS TS_Résumé"
          With [TS_Résumé]
               .ClearContents
               .ListObject.Resize .Offset(-1).Resize(UBound(TbGlob) + 1)
          End With
     
          [TS_Résumé] = TbGlob
     End If

End Sub

'Mise à jour des TS suivis
Sub MàJ_TSlistes(Cible As Range)
     
     Dim wsh As Worksheet, Zone As Range, Ligne As Range, C As Range
     Dim Tb_TS, TS, Idx As Long, No, Col As String
     
     Set wsh = Sh_Listes
     Tb_TS = Sh_Tables.[TS_NomsTS]
     
     For Each Zone In Cible.Areas: For Each Ligne In Zone.Rows  '(Si sélection multiple, par zone de la sélection puis par ligne de chaque zone)
          'Numéro d'identification de la ligne concernée
          No = Intersect(Ligne.EntireRow, wsh.Evaluate(NomTSRésumé & "[" & Repère & "]")).Value
          For Each TS In Tb_TS
               'N° de la ligne dans le TS
               Idx = 0
               On Error Resume Next: Idx = WorksheetFunction.Match(No, wsh.Evaluate(TS & "[" & Repère & "]"), 0): On Error GoTo 0
               If Idx > 0 Then
                    For Each C In Ligne
                         'Nom de la colonne
                         Col = Intersect(C.EntireColumn, wsh.Evaluate(NomTSRésumé & "[#Headers]"))
                         'Modification de la cellule
                         wsh.Evaluate(TS & "[" & Col & "]").Cells(Idx) = C
                    Next C
               End If
          Next TS
     Next Ligne, Zone

End Sub

'MàJ de la liste des "Contractants" pour la validation de données du nom recherché
Sub MàJ_Liste_Contractants()

     Dim DC As Object
     Set DC = CreateObject("Scripting.Dictionary")
     
     For Each TS In Sh_Tables.[TS_NomsTS]
          tb = Evaluate("UNIQUE(" & TS & "[" & Nom & "])")
          'Traitement pour le cas où l'on n'a qu'une ligne retournée
          On Error Resume Next: dd = UBound(tb, 2): No = Err.Number: On Error GoTo 0
          If No <> 0 Then
               DC(tb(1)) = tb(1)
          Else
               For i = 1 To UBound(tb, 1)
                    DC(tb(i, 1)) = tb(i, 1)
               Next
          End If
     Next
     'Liste des noms trouvé
     Items = DC.Items
     nb = DC.Count
     'Passage en 2 dimensions
     ReDim tt(1 To nb, 1 To 1)
     For i = 1 To nb
          tt(i, 1) = Items(i - 1)
     Next
     'Tri
     tb = WorksheetFunction.Sort(tt, 1, 1)
     
     'MàJ du TS "TS_Noms"
     With Sh_Tables.[TS_Noms]
          .ClearContents
          .ListObject.Resize .Offset(-1).Resize(nb + 1)
     End With
     Sh_Tables.[TS_Noms] = tb
End Sub

Voilà, voir le fichier joint
 

Pièces jointes

- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Retour