Dupliquer automatiquement par une macro des dates

Le 31/10/2019 à 12:06

Bonjour Voici mon problème.

Je dois dupliquer des dates (rien de compliqué) mais il faut que cela se fasse automatiquement (car trop fastidieux) et selon certaines conditions.

Dans ma colonne A j'ai mes allers

Dans ma colonne B j'ai mes retours

Je voudrais que ces dates ce duplique seulement si la date aller est différente de la date retour.

Pour arriver à une date identique.

[b]Je vous laisse un fichier test avec feuille 1 original du problème, Feuille 2 résultat attendu[/b]

10test.xlsx (10.19 Ko)
10test.xlsx (10.19 Ko)

Si vous pouvez m'aider j'en serait très reconnaissant.

Bien Cordialement.

Le 31/10/2019 à 14:36

Bonjour Linkmm, bonjour le forum,

Jai décalé les résultats à partir de la colonne D... Tu ajusteras.

Le code :

Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim TR() As Variant 'déclare la variable TR (Tableau des Résultats)
Dim I As Integer 'déclare la variable I (Incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim M As Integer 'déclare la variable M (incrément)
Dim DA As Long 'déclare la variable DA (Date Aller)
Dim DR As Long 'déclare la variable DR (Date Retour)

Set O = Worksheets("Original") 'définit l'onglet O (à adapter à ton cas)
TV = O.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
O.Range("D1").CurrentRegion.Clear 'efface d'éventuelles anciennes données à partir de D1
K = 1 'initialise la variable K
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    If TV(I, 1) = TV(I, 2) Then 'condition : si les données aller/retour sont identiques
        DA = CLng(DateSerial(Year(TV(I, 1)), Month(TV(I, 1)), Day(TV(I, 1)))) 'définit la date DA (en entier long)
        ReDim Preserve TR(1 To 2, 1 To K) 'redimensionne le tableau des résultat TR (2 lignes, K colonnes)
        TR(1, K) = DA 'récupère dans la ligne 1 de TR la date DA
        TR(2, K) = DA 'récupère dans la ligne 2 de TR la date DA
        K = K + 1 'incrémente K (ajoute une colonne au tableau des résultats TR)
    Else 'sinon (aller différent du retour)
        DA = CLng(DateSerial(Year(TV(I, 1)), Month(TV(I, 1)), Day(TV(I, 1)) - 1)) 'définit la date DA moins un jour (en entier long)
        DR = CLng(DateSerial(Year(TV(I, 2)), Month(TV(I, 2)), Day(TV(I, 2)))) 'définit la date DR (en entier long)
        For M = 1 To DR - DA 'boucle 2 : sur le monbre de jours entre les deux dates
            ReDim Preserve TR(1 To 2, 1 To K) 'redimensionne le tableau des résultat TR (2 lignes, K colonnes)
            TR(1, K) = DA + M 'récupère dans la ligne 1 de TR la valeur de DA + M jour
            TR(2, K) = DR 'récupère dans la ligne 2 de TR la date DR
            K = K + 1 'incrémente K (ajoute une colonne au tableau des résultats TR)
        Next M 'prochain jour de la boucle 2
    End If 'fin de la condition
Next I 'prichaine ligne de la boucle 1
O.Range("D1").Value = "Aller" 'écrit en D1
O.Range("E1").Value = "Retour" 'écrit en E1
'renvoie dans D2 redimensionnée le tableau TR transposé
O.Range("D2").Resize(UBound(TR, 2), UBound(TR, 1)).Value = Application.Transpose(TR)
O.Columns("D:E").NumberFormat = "dd/mm/yyyy" 'formate des colonne D et E
End Sub
Le 31/10/2019 à 15:04

Bonjour Thauthème,

Je te remercie sincèrement pour ta réponse...

Ton aide mets précieuse.

Alors ta macro est génial cependant il reste à détail technique qui dépasse mes compétence encore une fois.

Dans la Colonne C j'ai une série de code et il faudrait que ceux se duplique également avec la Macro.. et j'ai réessayé de changer ton code mais je n'arrive pas à avoir le résultat souhaité.

En claire la colonne C ne se duplique pas..

En tout cas merci beaucoup pour ce que tu as déjà fais.

3test-2-3.xlsm (18.81 Ko)
Le 31/10/2019 à 15:14

Bonjour,

Une proposition réalisée avec Power Query (sans VBA).

A te relire pour un complément d'informations.

Cdlt.

15test.xlsx (19.12 Ko)
Le 31/10/2019 à 15:45

Re,

Pour tes prochain fils, envoie systématiquement le bon fichier. Ça évite de perdre du temps !...

Le code corrigé, les résultats sont renvoyés dans un autre onglet :

Sub Macro1()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OS (Onglet Destination)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim TR() As Variant 'déclare la variable TR (Tableau des Résultats)
Dim I As Integer 'déclare la variable I (Incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim M As Integer 'déclare la variable M (incrément)
Dim DA As Long 'déclare la variable DA (Date Aller)
Dim DR As Long 'déclare la variable DR (Date Retour)

Set OS = Worksheets("Original") 'définit l'onglet OS (à adapter à ton cas)
Set OD = Worksheets("Résultat attendu") 'définit l'onglet OD (à adapter à ton cas)
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
OD.Range("A1").CurrentRegion.Clear 'efface d'éventuelles anciennes données
K = 1 'initialise la variable K
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    If TV(I, 1) = TV(I, 2) Then 'condition : si les données aller/retour sont identiques
        DA = CLng(DateSerial(Year(TV(I, 1)), Month(TV(I, 1)), Day(TV(I, 1)))) 'définit la date DA (en entier long)
        ReDim Preserve TR(1 To 3, 1 To K) 'redimensionne le tableau des résultat TR (2 lignes, K colonnes)
        TR(1, K) = DA 'récupère dans la ligne 1 de TR la date DA
        TR(2, K) = DA 'récupère dans la ligne 2 de TR la date DA
        TR(3, K) = TV(I, 3) 'récupère dans la ligne 3 de TR la donnée en colonne 3 de TV (=> transposition)
        K = K + 1 'incrémente K (ajoute une colonne au tableau des résultats TR)
    Else 'sinon (aller différent du retour)
        DA = CLng(DateSerial(Year(TV(I, 1)), Month(TV(I, 1)), Day(TV(I, 1)) - 1)) 'définit la date DA moins un jour (en entier long)
        DR = CLng(DateSerial(Year(TV(I, 2)), Month(TV(I, 2)), Day(TV(I, 2)))) 'définit la date DR (en entier long)
        For M = 1 To DR - DA 'boucle 2 : sur le monbre de jours entre les deux dates
            ReDim Preserve TR(1 To 3, 1 To K) 'redimensionne le tableau des résultat TR (2 lignes, K colonnes)
            TR(1, K) = DA + M 'récupère dans la ligne 1 de TR la valeur de DA + M jour
            TR(2, K) = DR 'récupère dans la ligne 2 de TR la date DR
            TR(3, K) = TV(I, 3) 'récupère dans la ligne 3 de TR la donnée en colonne 3 de TV (=> transposition)
            K = K + 1 'incrémente K (ajoute une colonne au tableau des résultats TR)
        Next M 'prochain jour de la boucle 2
    End If 'fin de la condition
Next I 'prichaine ligne de la boucle 1
OD.Range("A1").Value = "Aller" 'écrit en D1
OD.Range("B1").Value = "Retour" 'écrit en E1
OD.Range("C1").Value = "Retour" 'écrit en E1
'renvoie dans D2 redimensionnée le tableau TR transposé
OD.Range("A2").Resize(UBound(TR, 2), UBound(TR, 1)).Value = Application.Transpose(TR)
OD.Columns("A:B").NumberFormat = "dd/mm/yyyy" 'formate des colonne D et E
End Sub
Le 06/11/2019 à 13:32

Bonjour,

Désolé pour la longueur d'attente pour ma réponse.

Après avoir travaillé dessus j'ai pu le réadapter à mon cas et je te remercie.

La solution est parfaite

Rechercher des sujets similaires à "dupliquer automatiquement macro dates"