XL 2016 Macro copier/coller/effacer

[chinel]

Bonsoir, j'ai un fichier mais je ne trouve pas la solution propre pour faire un copier/coller de certaines cellules, merci de votre aide

 

[Hasco]

Bonjour,

Proposition par deux boutons et leur macro respective :
1 - Archiver
2 - Nettoyer

Cordialement

 

[sylvanu]

Bonjour Chinel, Hasco,
(Edit: J'ai modifié le code suite à bug.)
Une autre approche en PJ. L'archivage se fait si on tente de modifier la date.
J'ai modifié l'entrée mois/année pour simplifier. Avec en Feuil1 :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo Fin
    'If Target.Count > 5 Then Exit Sub
    If Not Intersect(Target, Range("B2:I2")) Is Nothing Then
        Réponse = MsgBox("Vous êtes sur le point de modifier la date de début." & Chr(10) & "Voulez vous archiver avant ?", vbYesNo + vbQuestion, "ATTENTION")
        If Réponse = vbNo Then Exit Sub
        Application.EnableEvents = False
        Archiver
        Application.EnableEvents = True
    End If
Fin:
End Sub
Sub Archiver()
    Application.ScreenUpdating = False
    With Sheets("Archivage")
        DL = Range("C65500").End(xlUp).Row
        For L = 7 To DL
            On Error Resume Next
            Colonne = Application.Match(Cells(L, "C"), .[1:1], 0)
            If IsError(Colonne) Then ' Nom n'existe pas
                .Cells(1, 1 + .Cells(1, .Columns.Count).End(xlToLeft).Column) = Cells(L, "C")
                Colonne = .Cells(1, .Columns.Count).End(xlToLeft).Column
            End If
            Ligne = 1 + .Cells(65000, Colonne).End(xlUp).Row
            For C = 4 To 34
                If LCase(Cells(L, C)) = "x" Then
                        .Cells(Ligne, Colonne) = Cells(6, C)
                        Ligne = 1 + .Cells(65000, Colonne).End(xlUp).Row
                End If
            Next C
        Next L
        .Columns.AutoFit
    End With
    Range("D7:AH" & DL).ClearContents
End Sub

 

[chinel]

Bonjour,

Proposition par deux boutons et leur macro respective :
1 - Archiver
2 - Nettoyer

Cordialement

Merci beaucoup super travail ! Bon week-end à vous !

 

[chinel]

Bonjour Chinel, Hasco,
(Edit: J'ai modifié le code suite à bug.)
Une autre approche en PJ. L'archivage se fait si on tente de modifier la date.
J'ai modifié l'entrée mois/année pour simplifier. Avec en Feuil1 :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo Fin
    'If Target.Count > 5 Then Exit Sub
    If Not Intersect(Target, Range("B2:I2")) Is Nothing Then
        Réponse = MsgBox("Vous êtes sur le point de modifier la date de début." & Chr(10) & "Voulez vous archiver avant ?", vbYesNo + vbQuestion, "ATTENTION")
        If Réponse = vbNo Then Exit Sub
        Application.EnableEvents = False
        Archiver
        Application.EnableEvents = True
    End If
Fin:
End Sub
Sub Archiver()
    Application.ScreenUpdating = False
    With Sheets("Archivage")
        DL = Range("C65500").End(xlUp).Row
        For L = 7 To DL
            On Error Resume Next
            Colonne = Application.Match(Cells(L, "C"), .[1:1], 0)
            If IsError(Colonne) Then ' Nom n'existe pas
                .Cells(1, 1 + .Cells(1, .Columns.Count).End(xlToLeft).Column) = Cells(L, "C")
                Colonne = .Cells(1, .Columns.Count).End(xlToLeft).Column
            End If
            Ligne = 1 + .Cells(65000, Colonne).End(xlUp).Row
            For C = 4 To 34
                If LCase(Cells(L, C)) = "x" Then
                        .Cells(Ligne, Colonne) = Cells(6, C)
                        Ligne = 1 + .Cells(65000, Colonne).End(xlUp).Row
                End If
            Next C
        Next L
        .Columns.AutoFit
    End With
    Range("D7:AH" & DL).ClearContents
End Sub

Super boulot comme d'habitude ! Je préfère cette manière plus ordonner mais tous les 2 super travail ! Bon week-end à vous !