Boucle qui fonctionne à moitié [Résolu]

Signaler
Messages postés
16
Date d'inscription
jeudi 5 décembre 2019
Statut
Membre
Dernière intervention
7 janvier 2020
-
ngio1301
Messages postés
16
Date d'inscription
jeudi 5 décembre 2019
Statut
Membre
Dernière intervention
7 janvier 2020
-
Bonjour,
Je rencontre un petit souci sur une macro qui doit récupérer des infos sur une feuille pour les placer sur une autre. La boucle ne va pas jusqu'au bout pour prendre toutes les valeurs.
Etant donnée mon petit niveau en VBA je sollicite votre aide. Merci d'avance pour votre aide.
image des feuilles.





Le code est le suivant:

Sub MaRécup()
Dim ws As Worksheet
Dim col_en_cours As Long
Dim Der_col As Long
Dim ligne_en_cours As Long
Dim Der_lin As Long
Dim CM As Range
Dim AR As Range
Dim AIG As Range
Dim RD As Range
Dim RD1 As Range

Set ws = Feuil1
Der_col = ws.Cells(1, Columns.Count).End(xlToLeft).Column
Der_lin = ws.Cells(Rows.Count, 1).End(xlUp).Row

For col_en_cours = 1 To Der_col
For i = 1 To 32
If Cells(i, col_en_cours).Value = Date Then
Cells(i, col_en_cours).Interior.ColorIndex = 4
Cells(i, col_en_cours).Select
With Selection
For ligne_en_cours = 1 To Der_lin
For j = 1 To 7
If Cells(j, col_en_cours).Value = "CM" Then
Cells(j, col_en_cours).EntireRow.End(xlToLeft).Select
Selection.Copy
With Selection
Sheets("lundi").Activate
Set CM = Worksheets("lundi").Cells.Find(What:="CM", After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not CM Is Nothing Then
CM.Offset(0, 1).Select
ActiveCell = ClearContents
Selection.PasteSpecial xlValues
Application.CutCopyMode = xlCut
End If
End With

ElseIf Cells(j, col_en_cours).Value = "AR" Then
Cells(j, col_en_cours).EntireRow.End(xlToLeft).Select
Selection.Copy
With Selection
Sheets("lundi").Activate
Set AR = Worksheets("lundi").Cells.Find(What:="AR", After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not AR Is Nothing Then
AR.Offset(0, 1).Select
ActiveCell = ClearContents
Selection.PasteSpecial xlValues
Application.CutCopyMode = xlCut
End If
End With

ElseIf Cells(j, col_en_cours).Value = "AIG" Then
Cells(j, col_en_cours).EntireRow.End(xlToLeft).Select
Selection.Copy
With Selection
Sheets("lundi").Activate
Set AIG = Worksheets("lundi").Cells.Find(What:="AIG", After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not AIG Is Nothing Then
AIG.Offset(0, 1).Select
ActiveCell = ClearContents
Selection.PasteSpecial xlValues
Application.CutCopyMode = xlCut
End If
End With

ElseIf Cells(j, col_en_cours).Value = "RD" Then
Cells(j, col_en_cours).EntireRow.End(xlToLeft).Select
Selection.Copy
With Selection
Sheets("lundi").Activate
Set RD = Worksheets("lundi").Cells.Find(What:="RD", After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not RD Is Nothing Then
RD.Offset(0, 1).Select
ActiveCell = ClearContents
Selection.PasteSpecial xlValues
Application.CutCopyMode = xlCut
End If
End With

ElseIf Cells(j, col_en_cours).Value = "RD1" Then
Cells(j, col_en_cours).EntireRow.End(xlToLeft).Select
Selection.Copy
With Selection
Sheets("lundi").Activate
Set RD1 = Worksheets("lundi").Cells.Find(What:="RD1", After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not RD1 Is Nothing Then
RD1.Offset(0, 1).Select
ActiveCell = ClearContents
Selection.PasteSpecial xlValues
Application.CutCopyMode = xlCut
End If
End With
End If
Next
Next
End With
End If
Next
Next

End Sub

6 réponses

Messages postés
2060
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
25 janvier 2020
255
Bonjour,

Avant d'aller plus loin, dans votre code, à quoi correspond Set ws = Feuil1 , parce que je ne vois aucune feuille "Feuil1".
Et si avant de déposer votre code, vous expliquiez en détail ce que vous voulez faire, parce que les 2 images ne sont pas très explicites.
-Comment se fait la répartition des postes?
-De quelle feuille vers quelle autre feuille? de Planning vers jour de la semaine ou bien l'inverse?

Cdlt
ngio1301
Messages postés
16
Date d'inscription
jeudi 5 décembre 2019
Statut
Membre
Dernière intervention
7 janvier 2020

Bonjour, Frenchie83
c'est l'index de la feuille Planning.
je veux prendre les infos sur la feuille planning selon les dates sur les feuilles de lun à dim.

Exemple: semaine du: 16 au 22 Décembre 2019
il faut que Excel regarde la date sur chaque feuille et aille chercher sur la feuille planning la date correspondante. Ensuite, contrôler chaque cellule de la colonne correspondant à la date, pour trouver les postes et les périodes. Aller à la première colonne du tableau pour copier le nom de l'agent et le coller dans un tableau situé sur la feuille correspondant à la date, ceci en vérifiant si l'agent est de matinée soirée ou nuit afin de l'écrire dans la partie concernée.

Récupérer les données de la feuille planning vers les feuilles lun à dim.
Voilà, je pense avoir tout dit. Merci pour votre aide.

je peux vous envoyer le fichier afin de mieux l’appréhender?
Messages postés
2060
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
25 janvier 2020
255
Bonjour,

Allez sur https://mon-partage.fr/
Étape 1 : clicquez sur la grande case longue, ou sur le bouton jaune
« CHOISIR UN FICHIER » ; sélectionnez le fichier à joindre.

Étape 2 : clicquez sur « Modifier la durée de partage » ; à droite
et plus haut, coche la case pour pouvoir entrer les 2 dates
de début et fin : à sélectionner dans le petit calendrier.

Étape 3 : clicquez sur le bouton jaune Uploader (en bas de la page) ; attendre un peu
que le fichier soit chargé ; vous pourrez ensuite récupérer le lien de
téléchargement.
Messages postés
2060
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
25 janvier 2020
255
Voilà

le fichier
https://mon-partage.fr/f/y2yyPLJs/

le code utilisé
Sub Repartition()
    Dim Derlig_Planning As Long
    Dim DateATraiter As Date
    
    Application.ScreenUpdating = False
    Set f1 = Sheets("Lundi")
    Set f2 = Sheets("Mardi")
    Set f3 = Sheets("Mercredi")
    Set f4 = Sheets("Jeudi")
    Set f5 = Sheets("Vendredi")
    Set f6 = Sheets("Samedi")
    Set f7 = Sheets("Dimanche")
    Set f8 = Sheets("PLANNING")
    
    Derlig_Planning = f8.Range("A" & Rows.Count).End(xlUp).Row + 1
    ReDim nom(Derlig_Planning) As String
    ReDim Service(Derlig_Planning) As String
    ReDim poste(Derlig_Planning) As String
    
    For i = 1 To 8
        If Sheets(i).Name <> "PLANNING" Then
            Sheets(i).Range("B3:D1000").ClearContents
            DateATraiter = Sheets(i).[A1]
            Set c = f8.Rows(1).Find(DateATraiter, LookIn:=xlFormulas)
            If Not c Is Nothing Then
                For j = 4 To Derlig_Planning Step 2
                    nom(j) = f8.Cells(j - 1, "A")
                    poste(j) = f8.Cells(j, c.Column)
                    Service(j) = f8.Cells(j - 1, c.Column)
                Next j
                
                For j = 4 To Derlig_Planning Step 2
                    If Service(j) <> "" And poste(j) <> "" Then
                        Set e = Sheets(i).Rows(2).Find(Service(j), LookIn:=xlValues, lookat:=xlWhole)
                        If Not e Is Nothing Then
                            Set d = Sheets(i).Columns(1).Find(poste(j), LookIn:=xlValues, lookat:=xlWhole)
                            If Not d Is Nothing Then
                                Sheets(i).Cells(d.Row, e.Column) = nom(j)
                            End If
                        End If
                    End If
                Next j
            End If
        End If
        Set c = Nothing
        Set d = Nothing
        Set e = Nothing
    Next i
End Sub


Cdlt
ngio1301
Messages postés
16
Date d'inscription
jeudi 5 décembre 2019
Statut
Membre
Dernière intervention
7 janvier 2020

Merci pour l'aide.
J'ai chargé le code, mais il ne se passe rien?? J'ai tout relu, tout est ok mais c'est comme si il n'y avait aucun code.
Frenchie83
Messages postés
2060
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
25 janvier 2020
255 > ngio1301
Messages postés
16
Date d'inscription
jeudi 5 décembre 2019
Statut
Membre
Dernière intervention
7 janvier 2020

Parce que ça va très vite. Pour vous en assurer, effacez la journée de lundi, puis revenez sur la feuille "PLANNING" et cliquez sur le bouton. Que se passe t-il?
ngio1301
Messages postés
16
Date d'inscription
jeudi 5 décembre 2019
Statut
Membre
Dernière intervention
7 janvier 2020
> Frenchie83
Messages postés
2060
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
25 janvier 2020

Sur votre fichier ça fonctionne bien sauf que pour le doublon RD il ne me donne qu'un seul nom. Mais lorsque je mets le code dons mon fichier il ne fonctionne pas???
Frenchie83
Messages postés
2060
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
25 janvier 2020
255 > ngio1301
Messages postés
16
Date d'inscription
jeudi 5 décembre 2019
Statut
Membre
Dernière intervention
7 janvier 2020

Pour le doublon RD, je vais regarder.

Mais lorsque je mets le code dons mon fichier il ne fonctionne pas??? , pourquoi, votre fichier est-il différent de celui que vous avez envoyé?
Messages postés
2060
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
25 janvier 2020
255
Essayez ceci

Sub Repartition()
    Dim Derlig_Planning As Long
    Dim DateATraiter As Date
    
    Application.ScreenUpdating = False
    Set f1 = Sheets("Lundi")
    Set f2 = Sheets("Mardi")
    Set f3 = Sheets("Mercredi")
    Set f4 = Sheets("Jeudi")
    Set f5 = Sheets("Vendredi")
    Set f6 = Sheets("Samedi")
    Set f7 = Sheets("Dimanche")
    Set f8 = Sheets("PLANNING")
    
    Derlig_Planning = f8.Range("A" & Rows.Count).End(xlUp).Row + 1
    ReDim nom(Derlig_Planning) As String
    ReDim Service(Derlig_Planning) As String
    ReDim poste(Derlig_Planning) As String
    
    For i = 1 To 8
        If Sheets(i).Name <> "PLANNING" Then
            Sheets(i).Range("B3:D1000").ClearContents
            DateATraiter = Sheets(i).[A1]
            Set c = f8.Rows(1).Find(DateATraiter, LookIn:=xlFormulas)
            If Not c Is Nothing Then
                For j = 4 To Derlig_Planning Step 2
                    nom(j) = f8.Cells(j - 1, "A")
                    poste(j) = f8.Cells(j, c.Column)
                    Service(j) = f8.Cells(j - 1, c.Column)
                Next j
                
                For j = 4 To Derlig_Planning Step 2
                    If Service(j) <> "" And poste(j) <> "" Then
                        Set e = Sheets(i).Rows(2).Find(Service(j), LookIn:=xlValues, lookat:=xlWhole)
                        If Not e Is Nothing Then
                        With Sheets(i).Range("A3:A" & Derlig_Planning)
                            Set d = .Find(poste(j), LookIn:=xlValues, lookat:=xlWhole)
                            If Not d Is Nothing Then
                                    Pos = d.Address
                                Do
                                    If Sheets(i).Cells(d.Row, e.Column) = "" Then
                                        Sheets(i).Cells(d.Row, e.Column) = nom(j)
                                    Else
                                        Set d = .FindNext(d)
                                    End If
                                Loop While Not d Is Nothing And d.Address <> Pos
                            End If
                        End With
                        End If
                    End If
                Next j
            End If
        End If
        Set c = Nothing
        Set d = Nothing
        Set e = Nothing
    Next i
    Set f1 = Nothing
    Set f2 = Nothing
    Set f3 = Nothing
    Set f4 = Nothing
    Set f5 = Nothing
    Set f6 = Nothing
    Set f7 = Nothing
    Set f8 = Nothing
End Sub
ngio1301
Messages postés
16
Date d'inscription
jeudi 5 décembre 2019
Statut
Membre
Dernière intervention
7 janvier 2020

Un grand merci pour votre aide précieuse. Tout fonctionne à merveilles!!!
Messages postés
2060
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
25 janvier 2020
255
Bonsoir,

je peux vous envoyer le fichier afin de mieux l’appréhender?
Oui, si possible et sans données confidentielles bien sûr?

Cdlt
ngio1301
Messages postés
16
Date d'inscription
jeudi 5 décembre 2019
Statut
Membre
Dernière intervention
7 janvier 2020

Comment je vous l'envoie? Je n'ai pas trouvé de bouton pour les pièces jointes??
Frenchie83
Messages postés
2060
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
25 janvier 2020
255 > ngio1301
Messages postés
16
Date d'inscription
jeudi 5 décembre 2019
Statut
Membre
Dernière intervention
7 janvier 2020

J'ai compris, j'ai remplacé Matinée par M , Soirée par S et Nuit par N, faites la même chose sur votre fichier

Pour le doublon, RD, je ne comprends pas où est le problème., Pourquoi mettre sur 2 lignes?.
ngio1301
Messages postés
16
Date d'inscription
jeudi 5 décembre 2019
Statut
Membre
Dernière intervention
7 janvier 2020
> Frenchie83
Messages postés
2060
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
25 janvier 2020

Pour le doublon, RD, je ne comprends pas où est le problème., Pourquoi mettre sur 2 lignes?.
Ah ok cool!!
c'est un même poste tenu par 2 ou 4 agents
Messages postés
16
Date d'inscription
jeudi 5 décembre 2019
Statut
Membre
Dernière intervention
7 janvier 2020

Salut et merci pour les infos.
voici le lien
https://mon-partage.fr/f/EjAacmFm/