Discussion :

[kakqshi]

Bonjour,

je suis débutant et je bloque depuis 2 jours sur la création d'une macro qui me permettrait de couper les lignes respectants des conditions et de les coller à la fin d'une feuille du classeur.

Dans la colonne 1 se trouve des OF qui sont triés par numéros. Certains se répètent, d'autres non.

L'objectif étant de tester pour chaque OF si une date est présente dans la colonne 2. Si une date est présente, on passe à l'OF suivant et on ne fait aucune action.
Si aucune date n'est trouvée dans la colonne 2 de l'OF, alors on sélectionne l'ensemble des lignes correspondant à cet OF, on les coupe et on les colle à la suite de la feuille 2.

N° d'OF	Date
113	l31/01/2014
112	
112	31/01/2014
111	31/01/2014
110	
110	
110	
110	
109

Concrètement ici la macro devra tester la ligne de l'OF 113. Regarder s'il y a une date de présente. En l'occurrence là oui, donc il pourrait passer à l'OF 112.
Concernant l'OF 112, il teste la première ligne, s'aperçoit qu'il n'y a pas de date donc passe à la ligne suivante. Cette fois-ci, il y a bien une date, il peut passer à l'OF suivante.
Concernant l'OF 110, il teste jusqu'à la fin des occurrences de l'OF 110 et constate qu'il n'y a pas de date. À ce moment là, la macro devrait sélectionner les lignes de l'OF 110, les couper et les coller juste après la dernière ligne remplies de la "feuille2".
Pour l'OF 109, celui-ci est présent une fois et n'a pas de date donc à couper et coller dans la "feuille2".

Les déplacements relatifs ne me posent pas de problème, ni le fait de sélectionner une ligne pour la couper/coller à la fin d'un classeur.

Je bloque au niveau des conditions et ne sais pas par où commencer...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
sub testdate()
 
range("A2").select
do while activecell <> activecell.offset (1,0) 'faire action tant que même OF

Je vous remercie pour votre aide.
Bon weekend.

[danixdb]

Bonjour kakqshi

Je viens de faire un essai et j'arrive à ce que tu essayes de faire, ilo y a certainement plus efficace, mais je n'ai pas trouvé.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
 
Sub Test()
  Dim intLineD As Integer, intLineF As Integer
  Dim intOF As Integer
  Dim bolPaste As Boolean
 
  bolPaste = False
  ReDim aArray(100, 2)
  Cells(2, 1).Select
  Do While Not IsEmpty(ActiveCell.Value)
    intOF = ActiveCell.Value
    intLineD = ActiveCell.Row
    Do While intOF = ActiveCell.Value
      If IsEmpty(ActiveCell.Offset(0, 1).Value) Then
        bolPaste = True
      End If
 
      ActiveCell.Offset(1, 0).Select
    Loop
    intLineF = ActiveCell.Row - 1
 
    If bolPaste = True Then
      Range(Cells(intLineD, 1), Cells(intLineF, 2)).Select
      Selection.Cut
      Sheets("Feuil3").Select
      Range("A65000").End(xlUp).Select
      ActiveCell.Offset(1, 0).Select
      ActiveSheet.Paste
      bolPaste = False
      Sheets("Feuil2").Select
      Cells(intLineF + 1, 1).Select
    End If
  Loop
 
End Sub

Slts

[electrons]

Bonjour,

Je viens de créer une fonction et je l'ai testée, elle recopie les valeurs dans la Feuille2 qui est ici "Sheet2" car programme excel en anglais. Il faudra peut-être l'adapter.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Sub CopieOF()
'
'
Dim i As Integer
Dim j As Integer
Dim OFLu As Integer
Dim NumLgSh2 As Integer
Dim DateOK As Boolean
 
DateOK = False
NumLgSh2 = 1
i = 2
 
While Range("A" & i).Value <> Blank  'Boucle principale
    OFLu = Range("A" & i).Value 'Mémoriser le contenu de la cellule lue pour
                                'le comparer avec la suivante
    j = i
 
    While Range("A" & j).Value = OFLu 'parcours des lignes suivantes jusqu'à trouver une autre valeur
        If Range("B" & j).Value <> Blank Then 'Si date passage aux lignes suivantes
            DateOK = True
        End If
            j = j + 1
    Wend
 
    If DateOK = False Then 'Copie des valeurs dans la feuille Sheet2 pour lesquelles pas de date
        j = j - 1
        While i <= j
            Worksheets("Sheet2").Cells(NumLgSh2, 1).Value = Range("A" & i).Value
            NumLgSh2 = NumLgSh2 + 1
            i = i + 1
        Wend
 
    Else
        DateOK = False
        i = j
    End If
Wend
End Sub

Bon travail.

[kakqshi]

Bonjour,

merci pour vos réponses et le temps que vous avez consacré à essayer de m'aider.

J'ai essayé d'appliquer chacune de vos deux propositions mais aucune ne fonctionne réellement en situation avec mes données.

La proposition de danixdb me coupe et colle des OF qui ne répondent pas aux conditions.

Je me suis penché sur la proposition d'électrons qui fonctionne bien au niveau des conditions puisqu'elle me copie réellement les numéros d'OF sauf que cela coince au niveau du "collage".
Je n'arrive pas à adapter ta boucle à mon contenu.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
If DateOK = False Then 'Copie des valeurs dans la feuille Sheet2 pour lesquelles pas de date
        j = j - 1
        While i <= j
            Worksheets("Sheet2").Cells(NumLgSh2, 1).Value = Range("A" & i).Value
            NumLgSh2 = NumLgSh2 + 1
            i = i + 1
        Wend

J'aurais besoin de couper les OF et de les coller dans une autre feuille du classeur. À moins que l'erreur vienne de ma part, avec ta macro les OF remplacent le contenu des cellules A1 jusqu'à suivante.
J'aurais besoin de couper les OF concernés et de les coller à la première ligne vide de la page.

Ci-dessous mon code adapté à mes besoins. En rouge les modifications que j'ai tenté d'apporter qui ne fonctionnent pas du tout...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
Sub ExtractHebdo()
 
Dim i As Variant
Dim j As Variant
Dim OFLu As Variant
Dim NumLgSh2 As Variant
Dim DateOK As Boolean
    DateOK = False
   
    Sheets("Supprimés").Select
    NumLgSh2 = Cells.Find("*", , , , xlByRows, xlPrevious).Row
    NumLgSh2 = NumLgSh2 + 1
   
    i = 2
    'Affectation valeurs variables
   
    Sheets("Manquants").Select
    While Range("D" & i).Value <> Blank
    OFLu = Range("D" & i).Value 'Mémoriser le contenu de la cellule lue pour le comparer avec la suivante
    j = i
    'Boucle principale
   
    While Range("D" & j).Value = OFLu 'parcours des lignes suivantes jusqu'à trouver une autre valeur
        If Range("AV" & j).Value <> Blank Then 'Si date passage aux lignes suivantes
            DateOK = True
        End If
            j = j + 1
    Wend
    If DateOK = False Then
        j = j - 1
        While i <= j
            Cells(i, 1).Select
        Range(Selection, Selection.Columns(54)).Select
        Range(Selection.Rows(j - i + 1), Selection).Select
        Selection.cut
        Sheets("Supprimés").Select
        Cells(NumLgSh2, 1).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
            NumLgSh2 = NumLgSh2 + 1
            i = i + 1
        Wend
    'Copie des valeurs dans la feuille Supprimés pour lesquelles pas de date
   
    Else
        DateOK = False
        i = j
    End If
   
    Wend
 
End Sub

Pour la fameuse boucle, je pense qu'il serait plus judicieux de sélectionner de la première à la dernière ligne de l'OF à couper/coller plutôt que de faire ligne par ligne mais je ne trouve à l'heure actuelle pas la solution.
Il doit y avoir un problème de compteur je pense...

J'espère pouvoir vous relire.

Bonne fin de journée et encore merci pour votre aide.

[danixdb]

Bonjour kakqshi, electrons, Le Forum

Désolé de ne pas avoir compris exactement ta demande et donc de ne pas avoir pu y répondre correctement.

Si je comprends bien, tu souhaites mettre dans la feuille Supprimé, toutes les OF pour lesquelles la date est à blanc et ce même si une date a été déjà renseignée pour cette OF.
Donc dans l'exemple donné les OF 110 et 109, les autres restant dans la feuille d'origine.

Légère adaptation et cette fois je crois que j'ai la réponse, mais c'est à vérifier avec tes données

En pièce jointe, un fichier avec tes données et la macro à adapter pour coller complétement à ton besoin.

En espérant avoir répondu à ton attente.

Slts

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
 
 
Option Explicit
 
Sub Test()
  Dim intLineD As Integer, intLineF As Integer
  Dim intOF As Integer
  Dim bolPaste As Boolean
 
  bolPaste = False
  Cells(2, 1).Select
  Do While Not IsEmpty(ActiveCell.Value)
    intOF = ActiveCell.Value
    intLineD = ActiveCell.Row
    Do While intOF = ActiveCell.Value
      If IsEmpty(ActiveCell.Offset(0, 1).Value) Then
        bolPaste = True
      Else
        bolPaste = False
      End If
 
      ActiveCell.Offset(1, 0).Select
    Loop
    intLineF = ActiveCell.Row - 1
 
    If bolPaste = True Then
      Range(Cells(intLineD, 1), Cells(intLineF, 2)).Select
      Selection.Cut
      Sheets("Exclusions").Activate
      Range("A65000").End(xlUp).Select
      ActiveCell.Offset(1, 0).Select
      ActiveSheet.Paste
      bolPaste = False
      Sheets("Donnees").Select
      Cells(intLineF + 1, 1).Select
    End If
  Loop
 
End Sub

[kakqshi]

merci pour ta réponse.

Les OF que tu as cité qui doivent rester sont en effet ceux-là.
Dès lors qu'une date est renseignée dans la colonne 2 de l'exemple, on passe automatiquement à l'OF suivant. Electron a réussi à produire cette action avec sa macro.

Je n'ai pas réussi à produire ce résultat avec ta 2nde macro. Cela doit peut-être venir de mon adaptation.

Pour faciliter la compréhension, je joins un classeur que j'espère un peu plus explicite...

Cela fait plusieurs jours que je bute sur cette étape de ma macro globale qui m'empêche d'avancer... et je désespère un peu.

Merci pour votre soutien

[parmi]

Ce serait bien de savoir si les données peuvent être triées.
Ça pourrait changer le code un peu, je pense...
Mais ceci devrait fonctionner

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
    Dim I As Long, J As Long, nbLignes As Long
    Dim Fin As Long
    Dim LigneTo As Long
    Dim DateOK As Boolean
 
    nbLignes = Cells(Rows.Count, "A").End(xlUp).Row
    Fin = nbLignes
 
    For I = nbLignes To 2 Step -1
        If Range("D" & I) <> Range("D" & I - 1) Then
            For J = I To Fin
                If IsDate(Range("G" & J)) Then
                    DateOK = True
                    Exit For
                End If
            Next
            If Not DateOK Then
                LigneTo = Sheets("Supprimés").Cells(Rows.Count, "A").End(xlUp).Row + 1
                Rows(I & ":" & Fin).Copy Sheets("Supprimés").Range("A" & LigneTo)
                Rows(I & ":" & Fin).Delete
                Fin = I - 1
                DateOK = False
            Else
                DateOK = False
                Fin = I - 1
            End If
        End If
    Next