Boucle qui fonctionne à moitié

Résolu
ngio1301 Messages postés 49 Date d'inscription   Statut Membre Dernière intervention   -  
ngio1301 Messages postés 49 Date d'inscription   Statut Membre Dernière intervention   -
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

  1.
    Frenchie83 Messages postés 2254 Statut Membre 339
     
    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
    1
    1. ngio1301 Messages postés 49 Date d'inscription   Statut Membre Dernière intervention  
       
      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?
      0
  2. Frenchie83 Messages postés 2254 Statut Membre 339
     
    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.
    1
  3. Frenchie83 Messages postés 2254 Statut Membre 339
     
    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
    1
    1. ngio1301 Messages postés 49 Date d'inscription   Statut Membre Dernière intervention  
       
      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.
      0
      1. Frenchie83 Messages postés 2254 Statut Membre 339 > ngio1301 Messages postés 49 Date d'inscription   Statut Membre Dernière intervention  
         
        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?
        0
      2. ngio1301 Messages postés 49 Date d'inscription   Statut Membre Dernière intervention   > Frenchie83 Messages postés 2254 Statut Membre
         
        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???
        0
      3. Frenchie83 Messages postés 2254 Statut Membre 339 > ngio1301 Messages postés 49 Date d'inscription   Statut Membre Dernière intervention  
         
        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é?
        0
  4. Frenchie83 Messages postés 2254 Statut Membre 339
     
    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
    1
    1. ngio1301 Messages postés 49 Date d'inscription   Statut Membre Dernière intervention  
       
      Un grand merci pour votre aide précieuse. Tout fonctionne à merveilles!!!
      0

  5. Vous n’avez pas trouvé la réponse que vous recherchez ?

    Posez votre question
  6. Frenchie83 Messages postés 2254 Statut Membre 339
     
    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
    0
    1. ngio1301 Messages postés 49 Date d'inscription   Statut Membre Dernière intervention  
       
      Comment je vous l'envoie? Je n'ai pas trouvé de bouton pour les pièces jointes??
      0
      1. Frenchie83 Messages postés 2254 Statut Membre 339 > ngio1301 Messages postés 49 Date d'inscription   Statut Membre Dernière intervention  
         
        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?.
        0
      2. ngio1301 Messages postés 49 Date d'inscription   Statut Membre Dernière intervention   > Frenchie83 Messages postés 2254 Statut Membre
         
        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
        0
  7. ngio1301 Messages postés 49 Date d'inscription   Statut Membre Dernière intervention  
     
    Salut et merci pour les infos.
    voici le lien
    https://mon-partage.fr/f/EjAacmFm/
    0

Discussions similaires

La moitié de l'écran de ma smart tv est sombre sur une moiti
6rizzzly -
MPMP10 -

7 réponses
Ecran partiellement sombre TV Samsung
reedbedroom -
zebre -

3 réponses
TV écran à moitié noir
barbara29 -
Vaninooo -

12 réponses
Mon pc s'allume et s'éteint en boucle
Jack -
Daniel -

16 réponses
Mon ordinateur s'allume et s'eteint en boucle
mhmd_elmrni -
BiGaMeRz10 -

10 réponses