XL 2016 Macro copier/coller/effacer

chinel

XLDnaute Impliqué
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
 

Pièces jointes

  • Tennis Lambermont saison hiver vers.3.xlsm
    24.2 KB · Affichages: 12

sylvanu

XLDnaute Barbatruc
Supporter XLD
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 :
VB:
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
 

Pièces jointes

  • Tennis Lambermont saison hiver vers.3.xlsm
    25.6 KB · Affichages: 2
Dernière édition:

chinel

XLDnaute Impliqué
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 :
VB:
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 !
 

Discussions similaires

Réponses
56
Affichages
905
Réponses
10
Affichages
390