macro Résolu

Question

Bonjour, 
J ai un problème sur une macro qui ne s'exécute pas svp. La macro doit archiver les lignes sur l onglet archives selon trois condditions , mais celle-ci ne le fait pas et je n arrive pas à trouver pourquoi.
https://www.cjoint.com/c/GAbp63CrFvP 
Sub Archivage()
Application.ScreenUpdating = True
Dim Msg, Style, Title, Response, MyString 'Définition des variables pour le message d'information
Dim Cellule, DerniereLigne, Compteur 'Definition des varaible pour l'archivage des lignes
Msg = "Attention ce programme va archiver automatiquement les lignes soldées, Souhaitez-vous continuer?"    ' Définit le message.
Style = vbYesNo + vbInformation + vbDefaultButton2    ' Définit les boutons.
Title = "Archivage des lignes soldées"    ' Définit le titre.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then    ' L'utilisateur a choisi Oui.
    MyString = "Oui" ' Effectue le programme d'archivage
    Sheets("Suivi Sof").Select 'Selectionne l'onglet "Suivi Sof"
    Range("A3").Select 'Se positionne sur la cellule A3
    DerniereLigne = ActiveSheet.UsedRange.Row - 1 + _
                  ActiveSheet.UsedRange.Rows.Count 'Recherche la derniereligne de la zone
  MsgBox "Position dernière ligne : " & DerniereLigne
  For Compteur = DerniereLigne To 3 Step -1
   If Cells(Compteur, 8).Value = "" And _
     Cells(Compteur, 10).Value = "Soldé" And _
     Cells(Compteur, 11).Value = "Soldé" Then
     Sheets("Archives").Select 'Selectionne l'onglet "Archives"
     Rows("2:2").Select 'Selectionne la 2° ligne
     Selection.Insert Shift:=xlDown 'Insére une ligne
     Sheets("Suivi Sof").Select 'Selectionne l'onglet "Suivi Sof"
     Rows(Compteur).Select 'Selcetionne la ligne correpondant à la valeur compteur
     Selection.Copy 'Copie les valeurs de la ligne correspondant à la valeur compteur
     Sheets("Archives").Select 'Selectionne l'onglet "archives"
     Rows("2:2").Select 'Selectionne la 2° ligne qui est vide à ce stade
     Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False 'Colle les valeurs
     Sheets("Suivi Sof").Select 'Selectionne l'onglet "Suivi Sof"
        Application.CutCopyMode = False
     Selection.Delete Shift:=xlUp 'Efface la ligne archivée
  End If
  Next Compteur 'Ligne suivante, intruction liée à for
Else    ' L'utilisateur a choisi Non.
    MyString = "Non" ' Effectue une action.
    Exit Sub 'Sort du programme
End If
Range("A1").Select
End Sub
      EDIT : Ajout des balises de code (la coloration syntaxique).
Explications disponibles ici : ICI 
Merci d'y penser dans tes prochains messages.Merci pour votre aide

yg_be · Answer

Le code ne s'exécute pas, ou bien ne fait pas ce que tu souhaites?

michel_m · Answer

bonjour Louisamiel, yg_be 
Ton code parait  bien compliqué !
si j'ai compris
tu veux supprimer les lignes répondant à tes 3 conditions dans "suivi sof"et les transférer dans "archives" ?
si oui 
combien de lignes as tu d'utilisées dans "suivi sof"
combien de colonnes : A à.... ? 
ou mieux
Mettre un extrait du classeur ( 50 lignes environ)sans données confidentielles en pièce jointe sur « mon-partage.fr »et faire un clic droit-coller le raccourci  dans votre message 
Dans l’attente
 Michel

michel_m · Answer

Pas mal de lignes: c'est à dire ?
100, 1000,10000.... (dans suivi sof) 
le nombre de lignes déterminera une méthode traitement ou une autre
 Michel

f894009 · Answer

Bonjour,
Juste une remarque (sauf erreur de ma part):
Y a un probleme entre les tests et les colonnes a tester

michel_m · Answer

re,
merci F89 pour la remarque
en attendant une dernière vérif  
Option Explicit'-------------------------------------------------------------------Sub archiver_si()Dim Msg As String, Style, Title As String, Response As Byte, help, ctxtDim Derlig As Integer, Nbre As Integer, Lig As Integer, Cptr As Integer, TransferDim Ligvid As Integer    Application.ScreenUpdating = False    'préparation    Msg = "Attention ce programme va archiver automatiquement les lignes soldées, Souhaitez-vous continuer?"    ' Définit le message.    Style = vbYesNo + vbInformation + vbDefaultButton2    ' Définit les boutons.    Title = "Archivage des lignes soldées"    ' Définit le titre.    Response = MsgBox(Msg, Style, Title, help, ctxt)    If Response = vbNo Then Exit Sub    With Sheets("suivi sof")        'crée une colonne furtive permattant de tester les conditions        Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row        .Range("AA3:AA" & Derlig).FormulaLocal = "=(ESTVIDE(H3))*(L3=""soldé"")*(M3=""soldé"")"        'Nbre lignes à  transférer        Nbre = Application.CountIf(.Columns("AA"), 1)        'prise en compte ligne à tranf&rer        For Cptr = 1 To Nbre            Lig = .Columns("AA").Find(what:=1, after:=.Range("AA2"), LookIn:=xlValues).Row            Transfer = .Range(.Cells(Lig, "A"), .Cells(Lig, "Z"))            'report en archives            With Sheets("Archives")                Ligvid = .Columns("A").Find(what:="", after:=.Range("A2")).Row                With .Cells(Ligvid, "A").Resize(1, 26)                    .Value = Transfer                    .Borders.Weight = xlThin                End With             End With            'détruit la ligne sur "suivi sof"            .Rows(Lig).Delete        Next        'détruit la colonne de test        Columns("AA").Clear    End With    MsgBox "Archivage terminé"End Sub 
je repasse en fin d'apres midi
 Michel

michel_m · Answer

Bonjour
dans ta colonne J , TOUTES les lignes renvoie X, certaines ont été camouflées en écrivant rouge sur  fond rouge : CHAPEAU !!!
comme toutes les lignes renvoie X, l'archivage ne peut pas se faire
la formule est à refaire et c'est ton problème.

Macro

6 réponses

Discussions similaires

Newsletters