XL 2010 Création de tableau à partir d'un autre tableau

[Mak_tarmak]

Bonjour,

J'aimerai construire automatiquement un tableau "designé" dans l'onglet Tableau qui ne comportera que certaines colonnes de l'onglet extraction.

Si la colonne I de l'onglet Extraction comporte le mot Validée, je recopie la date de début de la colonne H, la description de la colonne D, la salle de la colonne B, le demandeur de la colonne E et ce pour chaque ligne qui répond au critère Validée dans le Tableau aux emplacements voulus.
De plus, certaines formations se déroulent sur 3 jours, j'aimerais donc créer 3 lignes avec les mêmes informations de ces mêmes colonnes mais avec une date de début différente correspondant aux 3 jours (ici en jaune).
Ce tableau, une fois généré dans l'onglet Tableau, pourra être modifié si des données ont changé entre temps.
Ce Tableau servira, grâce à des filtres avancés, à mettre à jour automatiquement (macro qui se déclenche quand on clique sur l'onglet Affichage je pense) les formations qui se réalisent le jour J (AUJOURDHUI()).

Je ne sais pas si j'ai été assez clair et si j'ai choisi la meilleure façon de procéder mais c'est dans un but de facilitation pour des personnes qui ne maitrisent pas l'usage d'excel.
Comme une image vaut mille mots, je vous joins mon fichier avec le tableau que j'ai créé manuellement pour illustrer ce que je souhaite.

Je vous remercie par avance pour votre aide,

 

[cp4]

Bonjour,

Je ne sais pas si j'ai bien compris ta demande car je ne retrouve pas le même nombre de lignes que toi.
Code à mettre un module standard et à tester. /!\ enregistrer fichier xlsm , à l'ouverture cliquer sur activer les macros.

Option Explicit

Sub Extraire()
    Dim Titre, dt As Integer, ws As Worksheet, cel As Range, n As Integer
    Set ws = ThisWorkbook.Worksheets("tableau")
    Titre = Array("DATE", "LIBELLE FORMATION", "SALLE", "ORGANISME /FORMATEUR", "REFERENT ACADEMIE", "PC")
    ws.Range("a1").CurrentRegion.ClearContents
    ws.Range("a1").Resize(1, 6) = Titre

    With Sheets("extraction")
        For Each cel In .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
            If IsDate(cel.Offset(, 6)) And IsDate(cel.Offset(, 7)) Then
                If cel.Offset(, 6) <> cel.Offset(, 7) Then
                    n = DateDiff("d", cel.Offset(, 6).Value2, cel.Offset(, 7).Value2)
                    If n > 0 Then
                        dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
                        For n = 0 To n
                            ws.Range("A" & dt + n) = cel.Offset(, 6).Value2 + n
                            ws.Range("A" & dt + n).NumberFormat = "m/d/yyyy"
                            ws.Range("B" & dt + n) = cel.Offset(, 3)
                            ws.Range("C" & dt + n) = cel.Offset(, 1)
                            ws.Range("E" & dt + n) = cel.Offset(, 4)
                        Next n
                    Else
                        If cel.Offset(, 8) = "Validée" Then
                            dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
                            ws.Range("A" & dt) = cel.Offset(, 6).Value2
                            ws.Range("A" & dt).NumberFormat = "m/d/yyyy"
                            ws.Range("B" & dt) = cel.Offset(, 3)
                            ws.Range("C" & dt) = cel.Offset(, 1)
                            ws.Range("E" & dt) = cel.Offset(, 4)
                        End If
                    End If
                End If
            End If
        Next cel
    End With
End Sub

edit: code modifié

 

[Mak_tarmak]

Bonjour,

Je ne sais pas si j'ai bien compris ta demande car je ne retrouve pas le même nombre de lignes que toi.
Code à mettre un module standard et à tester. /!\ enregistrer fichier xlsm , à l'ouverture cliquer sur activer les macros.

Option Explicit

Sub Extraire()
    Dim Titre, dt As Integer, ws As Worksheet, cel As Range, n As Integer
    Set ws = ThisWorkbook.Worksheets("tableau")
    Titre = Array("DATE", "LIBELLE FORMATION", "SALLE", "ORGANISME /FORMATEUR", "REFERENT ACADEMIE", "PC")
    ws.Range("a1").CurrentRegion.ClearContents
    ws.Range("a1").Resize(1, 6) = Titre

    With Sheets("extraction")
        For Each cel In .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
            If IsDate(cel.Offset(, 6)) And IsDate(cel.Offset(, 7)) Then
                If cel.Offset(, 6) <> cel.Offset(, 7) Then
                    n = DateDiff("d", cel.Offset(, 6).Value2, cel.Offset(, 7).Value2)
                    If n > 0 Then
                        dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
                        For n = 0 To n
                            ws.Range("A" & dt + n) = cel.Offset(, 6).Value2 + n
                            ws.Range("A" & dt + n).NumberFormat = "m/d/yyyy"
                            ws.Range("B" & dt + n) = cel.Offset(, 3)
                            ws.Range("C" & dt + n) = cel.Offset(, 1)
                            ws.Range("E" & dt + n) = cel.Offset(, 4)
                        Next n
                    Else
                        If cel.Offset(, 8) = "Validée" Then
                            dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
                            ws.Range("A" & dt) = cel.Offset(, 6).Value2
                            ws.Range("A" & dt).NumberFormat = "m/d/yyyy"
                            ws.Range("B" & dt) = cel.Offset(, 3)
                            ws.Range("C" & dt) = cel.Offset(, 1)
                            ws.Range("E" & dt) = cel.Offset(, 4)
                        End If
                    End If
                End If
            End If
        Next cel
    End With
End Sub

edit: code modifié

Bonjour cp4,
Tu as tout à fait compris ma demande.
J'ai créé un module pour affecter ta macro et ça marche nickel !
Un grand merci à toi,
Bonne journée

 

[Mak_tarmak]

Bonjour,

Je ne sais pas si j'ai bien compris ta demande car je ne retrouve pas le même nombre de lignes que toi.
Code à mettre un module standard et à tester. /!\ enregistrer fichier xlsm , à l'ouverture cliquer sur activer les macros.

Option Explicit

Sub Extraire()
    Dim Titre, dt As Integer, ws As Worksheet, cel As Range, n As Integer
    Set ws = ThisWorkbook.Worksheets("tableau")
    Titre = Array("DATE", "LIBELLE FORMATION", "SALLE", "ORGANISME /FORMATEUR", "REFERENT ACADEMIE", "PC")
    ws.Range("a1").CurrentRegion.ClearContents
    ws.Range("a1").Resize(1, 6) = Titre

    With Sheets("extraction")
        For Each cel In .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
            If IsDate(cel.Offset(, 6)) And IsDate(cel.Offset(, 7)) Then
                If cel.Offset(, 6) <> cel.Offset(, 7) Then
                    n = DateDiff("d", cel.Offset(, 6).Value2, cel.Offset(, 7).Value2)
                    If n > 0 Then
                        dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
                        For n = 0 To n
                            ws.Range("A" & dt + n) = cel.Offset(, 6).Value2 + n
                            ws.Range("A" & dt + n).NumberFormat = "m/d/yyyy"
                            ws.Range("B" & dt + n) = cel.Offset(, 3)
                            ws.Range("C" & dt + n) = cel.Offset(, 1)
                            ws.Range("E" & dt + n) = cel.Offset(, 4)
                        Next n
                    Else
                        If cel.Offset(, 8) = "Validée" Then
                            dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
                            ws.Range("A" & dt) = cel.Offset(, 6).Value2
                            ws.Range("A" & dt).NumberFormat = "m/d/yyyy"
                            ws.Range("B" & dt) = cel.Offset(, 3)
                            ws.Range("C" & dt) = cel.Offset(, 1)
                            ws.Range("E" & dt) = cel.Offset(, 4)
                        End If
                    End If
                End If
            End If
        Next cel
    End With
End Sub

edit: code modifié

Re-bonjour cp4,
Est-ce que tu pourrais me dire vers quelles fonctions je dois aller pour générer des fichiers powerpoint pour chaque jour de la semaine à partir du tableau lié à l'extraction ?
Cette extraction correspond aux formations qui se déroulent sur une semaine donc chaque date correspond à un jour de la semaine. Je souhaite générer un fichier powerpoint pour chaque jour de la semaine afin de l'afficher en diaporama sur un écran d'accueil car actuellement j'affiche excel en grand écran mais ce n'est pas très sexy à l'affichage.
En te remerciant pour ton aide,

 

[cp4]

Re-bonjour cp4,
Est-ce que tu pourrais me dire vers quelles fonctions je dois aller pour générer des fichiers powerpoint pour chaque jour de la semaine à partir du tableau lié à l'extraction ?
Cette extraction correspond aux formations qui se déroulent sur une semaine donc chaque date correspond à un jour de la semaine. Je souhaite générer un fichier powerpoint pour chaque jour de la semaine afin de l'afficher en diaporama sur un écran d'accueil car actuellement j'affiche excel en grand écran mais ce n'est pas très sexy à l'affichage.
En te remerciant pour ton aide,

Pour cette demande, je te conseille d'ouvrir une autre discussion.
Franchement, je ne l'ai jamais fait (excel vers powerpoint).
Bonne continuation.

 

[Mak_tarmak]

Pour cette demande, je te conseille d'ouvrir une autre discussion.
Franchement, je ne l'ai jamais fait (excel vers powerpoint).
Bonne continuation.

Merci à toi