Boucles et conditions multiples

Version imprimable

31/01/2014, 13h53
kakqshi

Boucles et conditions multiples
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:

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.

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:

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

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:

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.

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:

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:

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.

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:

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

03/02/2014, 19h44
kakqshi

1 pièce(s) jointe(s)

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 ;)

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:

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

03/02/2014, 21h29
kakqshi

Bonsoir parmi,

je viens de tester ton code il fonctionne parfaitement :mrgreen: !

Il peut y avoir tri mais je n'ai pas vu d'intérêt pour la macro.

Merci pour ta solution. Et merci à ceux qui ont essayé de m'aider.
A+ :ccool:
03/02/2014, 21h41
parmi

En fait, la boucle lit de bas en haut puisqu'il y a coupures de lignes.
Si la date apparaissait sur la 1ere occurrence d'un OF (la dernière ligne d'un OF), il n'y aurait plus lieu de refaire une 2e boucle pour chercher une date...

Il y a certainement d'autres façons d'y arriver, mais bon... celle-ci fonctionne, c'est l'important... ;)