Coller cellules les unes en dessous de autres

Bonjour,

A l'aide de la macro du fichier ci-joint, mes cellules se collent toujours sur une même cellule et donc cela supprime la valeur précédente.

Je n'arrive pas à copier coller les cellules les unes en dessous des autres.

Pourriez-vous m'aider svp?

Merci d'avance

8essai.xlsm (27.89 Ko)

Bonjour,

Ta variable z ne s'incrémente nulle part et reste donc égale à sa valeur initiale de 3.

Par ailleurs, tu reporte la référence projet à chaque fois que la date de ta colonne est inférieur à la date de ton projet. Donc les projets précédemment copiés qui respectaient aussi ces conditions sont écrasés.

Voilà une proposition (d'après ce que j'ai compris de ton besoin) :

Sub copy_cut()

Dim y As Integer, z As Integer

With Sheets("Dates envois réalisés (2)")
    For y = 2 To .Cells(.Rows.Count, 3).End(xlUp).Row 'Dernière ligne non vide
        For z = 2 To 13 'Parcourir les mois
            If Month(.Cells(y, 3)) = Month(Sheets("Echange standard").Cells(6, z)) Then Sheets("Echange standard").Cells(8, z) = .Cells(y, 1) 'Copier est inutile, on reporte juste la valeur
        Next z
    Next y
End With

End Sub

Bonjour Pedro22,

Voici à quoi doit ressembler le résultat attendu pour mieux saisir ce que je souhaite réaliser.

Les numéros des projets devant être préparés pour chaque mois de l'année sont reportés dans la colonne du bon mois correspondant.

Merci d'avance pour ton aide.

capture

2ème essai :

Sub copy_cut()

Dim y As Integer, z As Integer
Dim Dest As Worksheet

Set Dest = Sheets("Echange standard")

With Sheets("Dates envois réalisés (2)")
    For y = 2 To .Cells(.Rows.Count, 3).End(xlUp).Row
        For z = 2 To 13
            If Month(.Cells(y, 3)) = Month(Dest.Cells(6, z)) Then Dest.Cells(Dest.Cells(20, z).End(xlUp).Row + 1, z) = .Cells(y, 1)
        Next z
    Next y
End With

End Sub

On s'en rapproche mais ce n'est pas tout à fait ça

Il ne faut pas uniquement prendre en compte le moi mais le mois et l'année.

J'ai tenté ça mais sans succès :

Sub copy_cut()

Dim y As Integer, z As Integer
Dim Dest As Worksheet

Set Dest = Sheets("Echange standard")

With Sheets("Dates envois réalisés (2)")
    For y = 2 To .Cells(.Rows.Count, 3).End(xlUp).Row
        For z = 2 To 13
            If (Month(.Cells(y, 3)) And Year(.Cells(y, 3))) = (Month(Dest.Cells(6, z)) And Year(Dest.Cells(6, z))) Then Dest.Cells(Dest.Cells(20, z).End(xlUp).Row + 1, z) = .Cells(y, 1)
        Next z
    Next y
End With

End Sub

Dans un test logique, chaque élément doit renvoyer VRAI ou FAUX.

Par exemple :

If 1=1 And 2=2 Then...
If 1=1 Or False Then...

C'est pourquoi tes conditions écrites ainsi ne peuvent fonctionner. Tu dois d'abord comparer l'égalité de tes mois ET ensuite de tes années.

Merci beaucoup pour ton aide Pedro22. Voici le fichier en PJ qui fonctionne.

Je souhaiterais faire de même pour compléter le tableau du dessous "PLANNING ENVOI" mais petite subtilité, il faut aussi copier la "Date départ" correspondant à chaque projet

Pourrais-tu me donner un coup de main là dessus stp?

Merci

11essai.xlsm (29.05 Ko)

Bonjour,

Une petite idée ?

Merci

Bonjour,

Une petite idée ?

Merci

Essaye ceci :

Sub copy_paste()

Application.ScreenUpdating = False 'Désactive l'affichage en temps réel
Application.Calculation = xlCalculationManual 'Désactive le recalcul auto des formules Excel

Dim y As Integer, z As Integer, Lig As Integer
Dim Dest As Worksheet

Set Dest = Sheets("Echange standard")
Dest.Range("B8:M25").ClearContents
With Sheets("Dates envois réalisés (2)")
    'Parcourir la liste des projets
    For y = 2 To .Cells(.Rows.Count, 3).End(xlUp).Row
        'Parcourir les mois (Planning préparation)
        For z = 2 To 13
            If Month(.Cells(y, 3)) = Month(Dest.Cells(6, z)) And Year(.Cells(y, 3)) = Year(Dest.Cells(6, z)) Then Dest.Cells(Dest.Cells(25, z).End(xlUp).Row + 1, z) = .Cells(y, 1)
        Next z
        'Parcourir les mois (Planning envoi)
        For z = 2 To 24 Step 2
            If Month(.Cells(y, 4)) = Month(Dest.Cells(29, z)) And Year(.Cells(y, 4)) = Year(Dest.Cells(29, z)) Then
                Lig = Dest.Cells(100, z).End(xlUp).Row + 1 'Détermine l'indice de la première ligne vide du mois
                Dest.Cells(Lig, z) = .Cells(y, 1) 'Report de la référence projet
                Dest.Cells(Lig, z + 1) = .Cells(y, 2) 'Report de la date de début
            End If
        Next z
    Next y
End With

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Attention : la ligne contenant les dates dans chaque tableau de l'onglet "échange standard" ne doit pas changer !

Rechercher des sujets similaires à "coller dessous"