Extraire des données d'un planning calendrier perpétuel

Bonjour,

Tout d'abord, merci pour toutes les informations que j ai pu trouver sur votre site et qui m'ont déjà bien servi.

Voulant créer un planning de maintenance préventive, j' ai trouvé sur le site un fichier de planning avec calendrier perpétuel qui fonctionne à merveille.

Je voudrais maintenant lui rajouter une fonction permettant d'extraire un récapitulatif des actions à effectuer durant une période, en gros, on renseigne la date du début et celle de fin, et le fichier extrait les opération programmées durant cette période.

Le Hic, c'est que avec mon faible niveau en VBA, je ne sais pas par ou attaquer, les dates du calendrier perpétuel étant "flottantes" par rapport aux coordonnées des cellules, je sèche complètement...

Je joint un fichier allégé avec une feuille montrant le résultat tant espéré

Merci d'avance pour votre aide

Bonne soirée à tous.

Bonjour,

À quelle colonne correspond la date dans ton recap ? Parce que dans ton planning, tu n'as aucune date égale au 19 juillet ...

Bonjour,

En fait, j' ai pris cette date au hasard pour l' exemple, ces deux cellules (date de début et date de fin ) seraient à renseigner afin d avoir la liste des taches issues du planning .

Oui mais dans ton tableau tu n'as rien qui correspond au 19 juillet. Mais dans résultats attendu, ta 1ère date est le 19 juillet. Ça sort d'où ? Je n'arrive pas à voir

Edit :
Ah, ok, il faut aller voir dans la partie de droite, on ne tient pas compte des dates qui sont dans la partie de gauche ?

Le 19/07 , il y a un V au niveau de la ligne "ecluse mélangeur...)

la partie de gauche correspond aux dates de départ et aux fréquentiel, elle sert à établir le planning en partie droite

Bon, voici le début, mais ça foire, je ne sais pas pourquoi :

Sub extract()
Dim Debut As Date, Fin As Date, Plage As Range
Dim Trouve_Debut As Range, Trouve_fin As Range

Set Plage = Sheets("Planning").Range("V4:BE4")
Debut = Feuil1.Range("C7")
Fin = Feuil1.Range("C8")

Set Trouve_Debut = Plage.Find(What:=Debut, LookAt:=xlWhole)
Set Trouve_fin = Plage.Find(What:=Fin, LookAt:=xlWhole)

For Each cell In Range(Cells(6, Trouve_Debut), Cells(600, Trouve_fin))
    If cell.Value <> "" Then Debug.Print cell.Value
Next
End Sub

Set Trouve_Debut = Plage.Find(What:=Debut, LookAt:=xlWhole)

la valeur de Trouve_Debut reste égale à Nothing. Pourtant, si je boucle manuellement sur les cellules, il trouve bien une correspondance au bon moment. Je ne sais pas ce que j'ai mal fait dans le .find ?

Edit : il fallait déclarer debut et fin en long, je ne sais pas pourquoi

Bonjour,

@JoyeuxNoel, comme un format particulier a été appliqué sur la ligne 4, on ne peut pas chercher directement en l'état. Si tu essaies en manuel via CTRL + F tu verras qu'il ne trouveras pas de correspondance. La manipulation à réaliser est de taper 19 dans le champ de recherche et de spécifier le format d'affichage. Donc traduit en VBA cela donne :

Sub extract()
Dim Debut As Byte, Fin As Byte, Plage As Range
Dim Trouve_Debut As Range, Trouve_fin As Range
Dim cell As Variant
Application.FindFormat.NumberFormat = "dd"
Set Plage = Sheets("Planning").Range("V4:BE4")
Debut = Day(Feuil1.Range("C7"))
Fin = Day(Feuil1.Range("C8"))
Set Trouve_Debut = Plage.Find(What:=Debut, SearchFormat:=True)
Set Trouve_fin = Plage.Find(What:=Fin, SearchFormat:=True)
MsgBox "DEBUT : " & Trouve_Debut.Address & " FIN : " & Trouve_fin.Address 'Ajouté juste pour vérification
For Each cell In Range(Cells(6, Trouve_Debut), Cells(600, Trouve_fin))
    If cell.Value <> "" Then Debug.Print cell.Value
Next
End Sub

Je te laisse prendre la suite !

Cdlt,

PS : Par contre si on a plus de colonne avec par exemple plusieurs 19 de plusieurs mois, aucune idée du résultat ...

Edit : J'ai beau cherché en ayant déclaré en Long, les objets Trouve sont tjs égaux à Nothing sans la manipulation que j'ai décrite.

Re,

J'en suis là pour le moment. J'ai abandonné le .find et je suis passé à un match en fait.

Sub extract()
Dim Debut As Long, Fin As Long, Plage As Range, Fin_Planning As Integer, Fin_Resultat As Integer
Dim Trouve_Debut As Long, Trouve_fin As Long

Set Plage = Sheets("Planning").Range("V4:BE4")
Debut = Feuil1.Range("C7")
Fin = Feuil1.Range("C8")

Trouve_Debut = Application.Match(Debut, Plage, 0) + 21
Trouve_fin = Application.Match(Fin, Plage, 0) + 21

Fin_Planning = Sheets("Planning").Range("B1048576").End(xlUp).Row
Fin_Resultat = Feuil1.Range("I1048576").End(xlUp).Row

'feuil2.Range("C14:I" & Fin_Resulat) = ""

For Each cell In Range(Cells(6, Trouve_Debut), Cells(Fin_Planning, Trouve_fin))
    If cell.Value <> "" Then

    Debug.Print cell.Value
Next
End Sub

Autant de temps pour pondre ces quelques lignes daubées ... Je m'exaspère des fois.

Bon, voilà qui semble fonctionner.

Sub extract()
Dim Debut As Long, Fin As Long, Plage As Range, Fin_Planning As Integer, Fin_Resultat As Integer
Dim Trouve_Debut As Long, Trouve_fin As Long
Dim tableau()

Set Plage = Sheets("Planning").Range("V4:BE4")
Debut = Feuil1.Range("C7")
Fin = Feuil1.Range("C8")

Trouve_Debut = Application.Match(Debut, Plage, 0) + 21
Trouve_fin = Application.Match(Fin, Plage, 0) + 21

Fin_Planning = Sheets("Planning").Cells(5, 2).End(xlDown).Row
Fin_Resultat = Feuil1.Cells(13, 9).End(xlDown).Row

Feuil1.Range("C14:I" & Fin_Resultat) = ""

'Redimensionnement tableau
ReDim tableau(Fin_Planning, 7)

With Worksheets("Planning")
    I = 0
    For Each cell In .Range(.Cells(6, Trouve_Debut), .Cells(Fin_Planning, Trouve_fin))
        If cell.Value <> "" Then
    'Enregistrement des valeurs dans le tableau
            For j = 1 To 6
            tableau(I, 0) = .Cells(4, cell.Column)
            tableau(I, j) = .Cells(cell.Row, j)
            Next j
            I = I + 1
        End If
    Next cell
End With

Feuil1.Range("C14").Resize(UBound(tableau, 1), UBound(tableau, 2)).Value = tableau

Fin_Resultat = Feuil1.Range("I1048576").End(xlUp).Row

    ActiveWorkbook.Worksheets("résultat attendu").Sort.SortFields.Add Key:=Range( _
        "C14:C" & Fin_Resultat), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("résultat attendu").Sort
        .SetRange Range("C14:I" & Fin_Resultat)
        .Header = xlGuess
        .Apply
    End With
End Sub

D'autres feront mieux, je pars me coucher pour ma part.

Je ne sais pas pourquoi, mais cette instruction ne veut pas fonctionner si on n'est pas sur la feuille concernée. Il me semble pourtant avoir tout bien indexé ?

For Each cell In Sheets("Planning").Range(Cells(6, Trouve_Debut), Cells(Fin_Planning, Trouve_fin))

Bonjour,

Et un second jeu d'essais comme je dois absolument m'exercer sur les arrays :

Option Explicit
Option Base 1

Sub TEST()
Dim TABLO_F(), TABLO_I(), TABLO_II(), C As Byte, L%, I As Byte, LR%, C_DEB As Byte, C_FIN As Byte, PLAGE_I As Range, PLAGE_II As Range
With Worksheets("Planning")
    LR = .Cells(5, 2).End(xlDown).Row
    C_DEB = Application.WorksheetFunction.Match(Worksheets("résultat attendu").Range("C7"), .Range("V4:BE4"), 0) + 21
    C_FIN = Application.WorksheetFunction.Match(Worksheets("résultat attendu").Range("C8"), .Range("V4:BE4"), 0) + 21
    Set PLAGE_I = .Range(.Cells(6, 1), .Cells(LR, 6))
    Set PLAGE_II = .Range(.Cells(4, C_DEB), .Cells(LR, C_FIN))
    TABLO_I = Application.Transpose(PLAGE_I)
    TABLO_II = Application.Transpose(PLAGE_II)
    ReDim TABLO_F(7, 1)
    For C = 1 To UBound(TABLO_II, 1)
        For L = 3 To UBound(TABLO_I, 2)
            If TABLO_II(C, L) <> "" Then
                For I = 1 To 6
                    TABLO_F(I + 1, UBound(TABLO_F, 2)) = TABLO_I(I, L - 2)
                Next I
                TABLO_F(1, UBound(TABLO_F, 2)) = TABLO_II(C, 1)
                ReDim Preserve TABLO_F(7, UBound(TABLO_F, 2) + 1)
            End If
        Next L
    Next C
End With
Worksheets("résultat attendu").Range("C14").Resize(UBound(TABLO_F, 2) - 1, 7) = Application.WorksheetFunction.Transpose(TABLO_F)
End Sub

Cdlt,

Edit : Pour ton interrogation, je pense qu'il vaut mieux qualifier l'objet Cells avec son objet parent donc

With Worksheets("Planning")
    I = 0
    For Each cell In .Range(.Cells(6, Trouve_Debut), .Cells(Fin_Planning, Trouve_fin))
        If cell.Value <> "" Then
    'Enregistrement des valeurs dans le tableau
            tableau(I, 0) = .Cells(4, cell.Column)
            tableau(I, 1) = .Cells(cell.Row, 1)
            tableau(I, 2) = .Cells(cell.Row, 2)
            tableau(I, 3) = .Cells(cell.Row, 3)
            tableau(I, 4) = .Cells(cell.Row, 4)
            tableau(I, 5) = .Cells(cell.Row, 5)
            tableau(I, 6) = .Cells(cell.Row, 6)
            I = I + 1
        End If
    Next
End With

Dans ce cas j'ai pas d'erreur.

Super, testé et effectivement ça fonctionne bien. Effectivement avec ce que je faisais, les cells à l'intérieur du range(...) étaient mal indexées.

À noter que ta méthode est un peu plus difficile d'accès de prime abord, mais bigrement plus rapide.

Bonjour à tous,

Un grand merci à Joyeux Noel et Ergotamine de s'être penché sur mon problème

Mais j'avoue être un peu perdu dans vos modifs, pourriez vous me faire un petit récap du code car je nage ...

Merci beaucoup !

Bonjour,

Il n'y a pas un code mais deux alternatives dans nos posts respectifs :
- Celui de JoyeuxNoel qui itère à travers toutes les cellules, les charge dans un array, le décharge sur votre seconde feuille puis tri. Le code a été corrigé directement dans son dernier post suite à nos échanges.
- Le mien qui charge deux arrays et réalise des opérations de comparaison pour mettre des cellules dans un troisième array et qui est alors déchargé sur votre seconde feuille. Avec une petite modification quand à l'effacement de vos données dans la seconde feuille avant rechargement :

Sub TEST()
Dim TABLO_F(), TABLO_I(), TABLO_II(), C As Byte, L%, I As Byte, LR%, C_DEB As Byte, C_FIN As Byte, PLAGE_I As Range, PLAGE_II As Range
With Worksheets("Planning")
    LR = .Cells(5, 2).End(xlDown).Row
    C_DEB = Application.WorksheetFunction.Match(Worksheets("résultat attendu").Range("C7"), .Range("V4:BE4"), 0) + 21
    C_FIN = Application.WorksheetFunction.Match(Worksheets("résultat attendu").Range("C8"), .Range("V4:BE4"), 0) + 21
    Set PLAGE_I = .Range(.Cells(6, 1), .Cells(LR, 6))
    Set PLAGE_II = .Range(.Cells(4, C_DEB), .Cells(LR, C_FIN))
    TABLO_I = Application.Transpose(PLAGE_I)
    TABLO_II = Application.Transpose(PLAGE_II)
    ReDim TABLO_F(7, 1)
    For C = 1 To UBound(TABLO_II, 1)
        For L = 3 To UBound(TABLO_I, 2)
            If TABLO_II(C, L) <> "" Then
                For I = 1 To 6
                    TABLO_F(I + 1, UBound(TABLO_F, 2)) = TABLO_I(I, L - 2)
                Next I
                TABLO_F(1, UBound(TABLO_F, 2)) = TABLO_II(C, 1)
                ReDim Preserve TABLO_F(7, UBound(TABLO_F, 2) + 1)
            End If
        Next L
    Next C
End With
With Worksheets("résultat attendu").Range("C14")
    .CurrentRegion.Offset(1).Resize(.CurrentRegion.Rows.Count - 1).ClearContents
    .Resize(UBound(TABLO_F, 2) - 1, 7) = Application.WorksheetFunction.Transpose(TABLO_F)
End With
End Sub

Les deux codes sont fonctionnels, ils n'ont pas le même design et sur un grand jeu de données ont pourrait voir une différence en terme de vitesse d’exécution mais pas d'autres différences notables.

Cdlt,

Bonjour,

Pour faire bien, il faudrait trier le tableau en mémoire avant de coller les données, mais comme c'est un tableau à 2 dimensions, je ne sais pas faire.

Après de nombreux tests des 2 versions, les extractions fonctionnent mais certaines dates occasionnent systématiquement des erreurs . Je pense que je vais abandonner l'idée de pouvoir extraire les données par date et aborder le problème de l'exploitation du planning de manière différentes .

En tout cas, merci encore pour avoir pris du temps pour m'aider. :)

Oui effectivement je pense que c'est le mieux. Autant abandonner les efforts plutôt qu'essayer de comprendre pourquoi "certaines dates occasionnent systématiquement des erreurs"...

Evolution de la proposition :

Sub extract()
Dim Debut As Long, Fin As Long, Plage As Range, Fin_Planning As Integer, Fin_Resultat As Long
Dim Trouve_Debut As Long, Trouve_fin As Long
Dim tableau()

Set Plage = Sheets("Planning").Range("V4:BE4")
Debut = Feuil1.Range("C7")
Fin = Feuil1.Range("C8")

Trouve_Debut = Application.Match(Debut, Plage, 0) + 21
Trouve_fin = Application.Match(Fin, Plage, 0) + 21

Fin_Planning = Sheets("Planning").Cells(5, 2).End(xlDown).Row
Fin_Resultat = Feuil1.Cells(13, 9).End(xlDown).Row

Feuil1.Range("C14:I" & Fin_Resultat) = ""

'Redimensionnement tableau
ReDim tableau(Fin_Planning, 7)

With Worksheets("Planning")
    For Each COL In .Range(.Cells(6, Trouve_Debut), .Cells(Fin_Planning, Trouve_fin)).Columns
        For Each cell In COL.Cells
            If cell.Value <> "" Then
                For j = 1 To 6
                    tableau(I, 0) = .Cells(4, cell.Column)
                    tableau(I, j) = .Cells(cell.Row, j) '
                Next j
                    I = I + 1
            End If
        Next cell
    Next COL
End With

Feuil1.Range("C14").Resize(UBound(tableau, 1), UBound(tableau, 2)).Value = tableau

End Sub

(merci à Ergotamine pour le coup de main) 

Je voulais dire que , avec mon niveau en programmation, c’était très compliqué de comprendre les erreurs ...et ne voulant pas abuser de votre temps...

Cette dernière version a l'air de très bien faire le Job .

Quitte à me répéter, MERCI à vous deux pour votre dévouement, vous êtes top !!!

Cette version ne fait rien d'autre que ce qu'a proposé Ergotamine.

Quand tu avais des soucis avec des dates, ce n'étaient pas par hasard des dates qui étaient antérieures ou postérieures à celles affichées dans ton planning ?

Si tel était le cas, ce serait tout à fait normal. Nous ne l'avons pas géré pour le moment.

Oui, j' ai compris qu'il fallait "placer le planning" sur la période que l'on souhaite extraire quand j'ai testé la dernière version. Comme les différents types d'erreurs ne me parlent pas vraiment, je n avais pas fait le rapprochement avant...