Couper/coller automatique

[Marielou25]

Bonjour,

Je suis débutante en langage VBA et j'ai vraiment besoin d'aide...
A partir du fichier joint, j'aimerais provoquer une exécution automatique pour que toutes les ventes antérieures à 1 an se reportent directement dans l'onglet "historique" et se suppriment de l'onglet "stock" (autrement dit couper/coller).
Quelqu'un peut-il m'aider ?

Merci beaucoup 🙂

Marie

 

[kjin]

Re : Couper/coller automatique

Bonsoir,
Ton fichier ressemble vraiment étrangement beaucoup à celui-ci, Non 😕😕
Ou une coincidence subliminale sans doute...
A+
kjin

 

[Marielou25]

Re : Couper/coller automatique

Nous travaillons en effet sur le même sujet 😉

 

[kjin]

Re : Couper/coller automatique

Re,
Voir PJ
L'archivage se fait automatiquement à l'ouverture du fichier
A+
kjin

 

[Marielou25]

Re : Couper/coller automatique

Merci de ton aide précieuse !! 😀
Bonne soirée,

Marie

 

[kjin]

Re : Couper/coller automatique

Re,
Attention il y a une erreur dans le fichier !
Voir PJ modifiée
A+
kjin

 

[Marielou25]

Re : Couper/coller automatique

C'est mieux comme ça, merci

 

[Theymis]

Re : Couper/coller automatique

Bonjour, 🙂

Marielou25 et moi-même avons essayé d'appliquer les codes sur notre fichier source.
Pas de problème à l'ouverture si il y a un article à archiver. Mais si il y en a aucun cela met à l'ouverture :

Erreur d'exécution '13' Incompatibilité de type

En cliquant sur Débogage j'ai accés à mon code

Sub Archiver()
Dim tab1, tab2
Dim d As Date
Dim i#, dl#, msg$
With Feuil3
tab1 = .Range("n4:N" & .Range("J65000").End(xlUp).Row).Value
For i = UBound(tab1) To 1 Step -1
If IsDate(tab1(i, 1)) Then
d = CDate(tab1(i, 1))
If Date > DateSerial(Year(d) + 1, Month(d), Day(d)) Then
msg = msg & .Cells(i + 3, 1) & vbCr
tab2 = .Cells(i + 3, 1).Resize(1, 19).Value
With Feuil4
dl = .Range("A65000").End(xlUp).Row + 1
.Cells(dl, 1).Resize(1, 19) = tab2
End With
.Rows(i + 3).EntireRow.Delete
End If
End If
Next
End With
If msg <> "" Then MsgBox "Ces articles ont été archivés:" & vbCr & msg
End Sub

La ligne mise en gras et soulignée est celle qui s'affiche surlignée en jaune. Je pensais avoir tout adapaté mais un problème persiste. Dans le code j'ai changé les noms de feuilles et également les cellules concernées (mis en italique).

Merci pour votre aide,
Cordialement.

 

[kjin]

Re : Couper/coller automatique

Bonjour,
Et quoi faire sans fichier ?
A+
kjin

 

[Theymis]

Re : Couper/coller automatique

Oui excuse moi j'avais oublié de joindre le fichier.
Le mot de passe est : MARQUISE

Merci de ton aide 🙂

 

[kjin]

Re : Couper/coller automatique

Bonjour,
Désactive les automatismes lorsque tu joins un fichier, c'est fort désagréable...
J'utilise le CodeName des feuilles et non pas leur nom (celui affiché dans les onglets), ça évite les embrouilles lorsque qu'on décide de renommer les feuilles
En outre, les dates sont dans la colonne K et non pas N et le nb de colonnes est 13 et non pas 19
Par contre, je ne sais pas dans quelle feuille exporter les lignes donc tu adapteras
Pour garder l'idée du tableau (pour une question de rapidité s'il y a beaucoup d'items)

Sub Archiver()
Dim tab1, tab2
Dim D As Date
Dim i#, dl#, msg$
With Base_articles 'codename de la feuille Base articles
    tab1 = .Range("K1:K" & .Range("K65000").End(xlUp).Row).Value
    For i = UBound(tab1) To 1 Step -1
        If IsDate(tab1(i, 1)) Then
            D = CDate(tab1(i, 1))
            If Date > DateSerial(Year(D) + 1, Month(D), Day(D)) Then
                msg = msg & .Cells(i, 1) & vbCr
                tab2 = .Cells(i, 1).Resize(1, 13).Value
                With Feuil4 'codename de la feuille qui reçoit les lignes exportées ???
                    dl = .Range("A65000").End(xlUp).Row + 1
                    .Cells(dl, 1).Resize(1, 13) = tab2
                End With
                .Rows(i).EntireRow.Delete
            End If
        End If
    Next
End With
If msg <> "" Then MsgBox "Ces articles ont été archivés:" & vbCr & msg
End Sub

Reviens si ça coince
A+
kjin