XL 2016 Report de lignes sous condition

P

Petitom42

XLDnaute Nouveau
Bonjour à tous!

Merci de m'accueillir dans ce forum :)

Je cherche désespérément une solution pour reporter des lignes d'une feuille à l'autre en fonction d'une condition prédéfinie, mais je suis assez novice dans la matière.

Je joins un fichier contenant des tableaux : https://1drv.ms/x/s!AogS0o3MZfZJga4AQGJCAcLyEOw2Ew?e=i5UPvn

Dans l'onglet qui s'appelle télécardio, il faudrait que se reportent automatiquement toutes les lignes des autres onglets pour lesquelles il y a un O dans la colonne TC.
Ainsi à chaque fois que l'on rajoute un O dans cette colonne, la ligne correspondante serait automatiquement ajoutée dans l'onglet télécardio.
Il serait alors possible manuellement de rajouter des informations dans les colonnes supplémentaires.

Pensez-vous qu'il existe une solution pour mettre cela en place?

Merci d'avance
Thomas
 
Dernière édition:
Trier par date Trier par votes
P

Petitom42

XLDnaute Nouveau
pierrejean à dit:
Bonjour Petitom42
Un essai
Cliquez pour agrandir...
Bonjour,

La solution semble bonne, le problème est que lorsque je remplis les autres colonnes de l'onglet télécardiologie (dans les lignes qui viennent d'être créées), leur contenu s'efface dès que le tableau est mis à jour... Y'aurait-il une solution pour y remédier? Peut-être en reliant les données de cet onglet aux autres, si par exemple les données mises dans ces colonnes peuvent être retranscrites automatiquement dans des colonnes correspondantes dans les autres onglets?

Merci beaucoup pour votre aide!

Thomas
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour Petitom42, Pierre, JHA,

Voyez le fichier joint et cette macro dans le code de la feuille "Télécardio" :
VB: 
Private Sub Worksheet_Activate()
Dim ncol%, resu(), w As Worksheet, tablo, i&, n&, j%
ncol = 13 'nombre de colonnes à copier
ReDim resu(1 To Rows.Count, 1 To ncol)
For Each w In Worksheets
    If w.Name <> Me.Name Then
        tablo = w.UsedRange.Resize(, ncol)
        For i = 2 To UBound(tablo)
            If UCase(tablo(i, 10)) = "O" Then
                n = n + 1
                For j = 1 To ncol: resu(n, j) = tablo(i, j): Next j
            End If
        Next i
    End If
Next w
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
If n Then Cells(Cells(Rows.Count, 10).End(xlUp).Row + 1, 1).Resize(n, ncol) = resu
UsedRange.RemoveDuplicates Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10), Header:=xlYes 'supprime les lignes en doublon
Columns.AutoFit 'ajuste les largeurs
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Elle se déclenche quand on active la feuille.

Edit : dans la feuille "2019" des dates de naissance étaient des textes, je les ai corrigées.

A+
 

Pièces jointes

  • TC essai(1).xlsm
    76.5 KB · Affichages: 7
Dernière édition:
Vote positif 0 Vote négatif
P

Petitom42

XLDnaute Nouveau
Petitom42 à dit:
d'être créées), leur contenu s'efface dès que le tableau est mis à jour... Y'aurait-il une solution pour y remédier?
Cliquez pour agrandir...

job75 à dit:
Bonjour Petitom42,

Voyez le fichier joint et cette macro dans le code de la feuille "Télécardio" :
VB: 
Private Sub Worksheet_Activate()
Dim ncol%, resu(), w As Worksheet, tablo, i&, n&, j%
ncol = 13 'nombre de colonnes à copier
ReDim resu(1 To Rows.Count, 1 To ncol)
For Each w In Worksheets
    If w.Name <> Me.Name Then
        tablo = w.Cells(1).CurrentRegion.Resize(, ncol)
        For i = 2 To UBound(tablo)
            If UCase(tablo(i, 10)) = "O" Then
                n = n + 1
                For j = 1 To ncol: resu(n, j) = tablo(i, j): Next j
            End If
        Next i
    End If
Next w
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
If n Then Cells(Cells(Rows.Count, 10).End(xlUp).Row + 1, 1).Resize(n, ncol) = resu
UsedRange.RemoveDuplicates Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10), Header:=xlYes 'supprime les lignes en doublon
Columns.AutoFit 'ajuste les largeurs
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Elle se déclenche quand on active la feuille.

A+
Cliquez pour agrandir...
Bonjour,

Merci à vous aussi pour votre participation! Décidément vous êtes d'une disponibilité remarquable sur ce forum :)
Le problème avec cette formule est qu'elle rajout sans arrêt des doublons dès que je rajoute ou j'enlève des O dans les autres onglets...
Pas facile j'en suis conscient :/

Merci
Thomas
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Petitom42 à dit:
Le problème avec cette formule est qu'elle rajout sans arrêt des doublons dès que je rajoute ou j'enlève des O dans les autres onglets...
Cliquez pour agrandir...
Avec ma macro, dans la feuille "Télécardio" :

- toutes les lignes repérées "O" des feuilles sont ajoutées sous les lignes existantes, cela permet de conserver les données ajoutées manuellement danss cette feuille

- les lignes en doublons sur les colonnes 1 à 10 sont supprimées par RemoveDuplicates.
 
Vote positif 0 Vote négatif
P

Petitom42

XLDnaute Nouveau
job75 à dit:
Avec ma macro, dans la feuille "Télécardio" :

- toutes les lignes repérées "O" des feuilles sont ajoutées sous les lignes existantes, cela permet de conserver les données ajoutées manuellement danss cette feuille

- les lignes en doublons sur les colonnes 1 à 10 sont supprimées par RemoveDuplicates.
Cliquez pour agrandir...
Bonjour,
Je viens de rééssayer, et lorsque je modifie un O j'ai bien des lignes qui se rajoutent à la suite avec des valeurs en double, triple voire quadruple :/ Est-ce parce que je suis sous Excel 2013?
Par ailleurs lorsqu'on enlève un O dans l'onglet original il ne s'enlève pas dans la feuille télécardio...
Désolé et merci encore pour votre investissement.
Thomas
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour Petitom42, le fil, le forum,

En effet il faut traiter le tableau existant avant de restituer les résultats.

Dans ce fichier (2) on utilise un Dictionary pour repérer les lignes à supprimer :
VB: 
Private Sub Worksheet_Activate()
Dim ncol%, resu(), d As Object, w As Worksheet, tablo, i&, n&, x$, j%, repere(), ub%
ncol = 13 'nombre de colonnes à copier
ReDim resu(1 To Rows.Count, 1 To ncol)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each w In Worksheets
    If w.Name <> Me.Name Then
        tablo = w.UsedRange.Resize(, ncol)
        For i = 2 To UBound(tablo)
            If UCase(tablo(i, 10)) = "O" Then
                n = n + 1
                If IsNumeric(CStr(tablo(i, 1))) Then tablo(i, 1) = CDbl(tablo(i, 1)) 'en cas de valeur texte
                x = ""
                For j = 1 To ncol
                    resu(n, j) = tablo(i, j)
                    If j < 10 Then x = x & Chr(1) & tablo(i, j)
                Next j
                d(x) = ""
            End If
        Next i
    End If
Next w
'---repérages dans le tableau existant---
tablo = UsedRange.Resize(, 9)
ReDim repere(1 To UBound(tablo), 1 To 1)
For i = 2 To UBound(tablo)
    x = ""
    For j = 1 To 9
        x = x & Chr(1) & tablo(i, j)
    Next j
    If d.exists(x) Then repere(i, 1) = 1 'repère
Next i
repere(1, 1) = 1
'---1ère restitution et suppressions---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
ub = ncol + 1
With UsedRange
    .Columns(ub).EntireColumn.Insert 'insère une colonne auxiliaire
    .Columns(ub) = repere
    .EntireRow.Sort .Columns(ub) 'tri pour regrouper et accélérer
    On Error Resume Next 'si aucune SpecialCell
    .Columns(ub).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'suppressions
    .Columns(ub).EntireColumn.Delete 'supprime la colonne auxiliaire
    On Error GoTo 0
End With
'---2ème restitution---
If n Then Cells(Cells(Rows.Count, 10).End(xlUp).Row + 1, 1).Resize(n, ncol) = resu
UsedRange.RemoveDuplicates Array(1, 2, 3, 4, 5, 6, 7, 8, 9), Header:=xlYes 'supprime les lignes en doublon
Columns.AutoFit 'ajuste les largeurs
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Edit : j'ai modifié pour convertir les valeurs textes en colonnes A.

A+
 

Pièces jointes

  • TC essai(2).xlsm
    79.1 KB · Affichages: 2
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Dans la macro précédente j'ai ajouté une ligne pour convertir en colonnes A les valeurs textes en nombres.

Et s'il y a beaucoup de lignes en doublon entre les feuilles il vaut mieux utiliser ce fichier (3) :
Code: 
Private Sub Worksheet_Activate()
Dim ncol%, resu(), d As Object, w As Worksheet, tablo, i&, n&, x$, j%, repere(), ub%
ncol = 13 'nombre de colonnes à copier
ReDim resu(1 To Rows.Count, 1 To ncol)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each w In Worksheets
    If w.Name <> Me.Name Then
        tablo = w.UsedRange.Resize(, ncol)
        For i = 2 To UBound(tablo)
            If UCase(tablo(i, 10)) = "O" Then
                If IsNumeric(CStr(tablo(i, 1))) Then tablo(i, 1) = CDbl(tablo(i, 1)) 'en cas de valeur texte
                x = ""
                For j = 1 To 9
                    x = x & Chr(1) & tablo(i, j)
                Next j
                If Not d.exists(x) Then 'élimine les doublons entre les feuilles
                    n = n + 1
                    For j = 1 To ncol
                        resu(n, j) = tablo(i, j)
                    Next j
                    d(x) = ""
                End If
            End If
        Next i
    End If
Next w
'---repérages dans le tableau existant---
tablo = UsedRange.Resize(, 9)
ReDim repere(1 To UBound(tablo), 1 To 1)
For i = 2 To UBound(tablo)
    x = ""
    For j = 1 To 9
        x = x & Chr(1) & tablo(i, j)
    Next j
    If d.exists(x) Then repere(i, 1) = 1 'repère
Next i
repere(1, 1) = 1
'---1ère restitution et suppressions---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
ub = ncol + 1
With UsedRange
    .Columns(ub).EntireColumn.Insert 'insère une colonne auxiliaire
    .Columns(ub) = repere
    .EntireRow.Sort .Columns(ub) 'tri pour regrouper et accélérer
    On Error Resume Next 'si aucune SpecialCell
    .Columns(ub).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'suppressions
    .Columns(ub).EntireColumn.Delete 'supprime la colonne auxiliaire
    On Error GoTo 0
End With
'---2ème restitution---
If n Then Cells(Cells(Rows.Count, 10).End(xlUp).Row + 1, 1).Resize(n, ncol) = resu
UsedRange.RemoveDuplicates Array(1, 2, 3, 4, 5, 6, 7, 8, 9), Header:=xlYes 'supprime les lignes en doublon
Columns.AutoFit 'ajuste les largeurs
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
 

Pièces jointes

  • TC essai(3).xlsm
    79.4 KB · Affichages: 8
Vote positif 0 Vote négatif

Discussions similaires

P
  • Question
XL 2019 Bloquer la saisie dans une colonne sous condition
Réponses
1
Affichages
431
sylvanu
sylvanu
O
  • Question
XL 2016 Archivage de lignes sous condition
Réponses
7
Affichages
368
Staple1600
Staple1600
E
  • Question
Microsoft 365 Reporter les valeurs d'une colonne dans une autre tous les 3 lignes
Réponses
2
Affichages
567
Eric32000
E
C
  • Question
XL 2021 mise à jour automatique de proformas avec espacement conforme
Réponses
0
Affichages
502
chingilou
C
C
  • Question
XL 2019 Calcul automatique de Congé Payé
Réponses
0
Affichages
808
crystal13
C
P
  • Question
Microsoft 365 Probleme, Transfert de ligne sur une autre feuille du même fichier selon condition.
Réponses
1
Affichages
537
PascaleMT
P
D
  • Résolu(e)
XL 2010 Déplacer des lignes entières sous condition d'un tableau vers différents onglets
2
Réponses
20
Affichages
2 K
Djehnsr
D
C
  • Question
XL 2016 VBA - Insertion de lignes automatique sous condition et copier formats et formules dans la nouvelle ligne
Réponses
10
Affichages
1 K
clochette
C
J
  • Question
XL 2016 Création de macros diverses
Réponses
0
Affichages
1 K
Jérôme57
J
G
  • Résolu(e)
Microsoft 365 VBA : Numérotation de lignes à partir d'une ligne vide
Réponses
14
Affichages
3 K
GMeunier
G

Membres actuellement en ligne

8 membres et 160 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 496
Messages
2 110 236
Membres
110 708
dernier inscrit
novy16