Encore ces sacrées boucles !

WDAndCo · 29 Juillet 2013

Bonjoure le Forum

Une feuille doit se remplir toute seule.
Elles doit, parcourir tous les onglets à partir du 5eme
Le nombre de ligne est variable dans chaque onglets le nombre est en L1
Crée une ligne si la colonne Delais<>"" et si la colonne Dates Exécution est vide, et y mettre quelques informations
J'ai déjà une partie de code, mais la je bloque. Il n'y a qu'une ligne qui se crée par onglet.
Merci de modifier ce code.
Merci D'avance.

Code:

Private Sub Worksheet_Activate()
    [A2:I1000].ClearContents
Range("A1").Value = "RECAPITULATIF des Visites EF 5A n°7"
Range("A2").Value = "N° du CR"
Range("B2").Value = "Dates"
Range("C2").Value = "Lieux"
Range("D2").Value = "Installations"
Range("E2").Value = "Points à Amortir"
Range("F2").Value = "Delais"
Range("G2").Value = "Moyen"

LP = 0 'LP = Une Ligne Plus
    For i = 5 To Sheets.Count 'Tous les onglets a partir du 5eme
    
    nf = Sheets(i).Name
      ActiveSheet.Hyperlinks.Add Anchor:=Cells(i - 2, 1), Address:="", SubAddress:="'" & _
         nf & "'" & "!A1", TextToDisplay:=nf
    
    With Sheets(i)
    
        NL = ActiveSheet.Range("L1").Value 'Nb de ligne sur l'onglet
       
        For L = 12 To NL + 12
If ActiveSheet.Range("G" & L).Value <> "" And ActiveSheet.Range("H" & L).Value = "" Then LP = LP + 1:
   ActiveSheet.Range("A" & i - 2 + LP).Value = .Range("H6").Value:
   ActiveSheet.Range("B" & i - 2 + LP).Value = .Range("C8").Value:
   ActiveSheet.Range("C" & i - 2 + LP).Value = .Range("B12").Value:
   ActiveSheet.Range("D" & i - 2 + LP).Value = .Range("C" & L).Value:
   ActiveSheet.Range("E" & i - 2 + LP).Value = .Range("D" & L).Value:
   ActiveSheet.Range("F" & i - 2 + LP).Value = .Range("G" & L).Value

        Next L
  
    
    End With
   
Next i

    Range("A2:G2").Select
    Selection.AutoFilter
     Columns("A:G").Select
    ActiveWindow.Zoom = True
    Range("H1").Select
End Sub

Dominique

Dranreb · 29 Juillet 2013

Re : Encore ces sacrées boucles !

Bonjour.
Vous êtes sûr que c'est ActiveSheet. qu'il faut prendre pour le test ? Ce ne serait pas plutôt le . de With Sheets(i) ?
Un conseil: passez en revue les ActiveSheet et supprimez les tous. Mettre Me à la place quand vous être sûr de devoir désigner la feuille dont c'est la Worksheet_Activate.

WDAndCo · 30 Juillet 2013

Re : Encore ces sacrées boucles !

Bonjour le Forum
Merci Dranreb

J'ai trouvé ! ! Enfin presque.
Car il reste des petites bricoles,

1) Je n'ai plus les liens en colonne A
2) Le code n'est pas "propre" il y a une ligne de plusieurs Km

Code:

Private Sub Worksheet_Activate()
    [A2:I1000].ClearContents
Range("A1").Value = "RECAPITULATIF des Visites EF 5A n°7"
Range("A2").Value = "N° du CR"
Range("B2").Value = "Dates"
Range("C2").Value = "Lieux"
Range("D2").Value = "N° Points"
Range("E2").Value = "Installations"
Range("F2").Value = "Points à Amortir"
Range("G2").Value = "Delais"
Range("H2").Value = "Moyen"

DL = 3 'DL = Derniere Ligne

    For i = 5 To Sheets.Count 'Tous les onglets a partir du 5eme
    
    nf = Sheets(i).Name
      ActiveSheet.Hyperlinks.Add Anchor:=Cells(i - 2, 1), Address:="", SubAddress:="'" & _
         nf & "'" & "!A1", TextToDisplay:=nf
    
    With Sheets(i)
    
      NL = .Range("L1").Value 'Nb de ligne sur l'onglet
       
        For L = 12 To NL + 11
If .Range("G" & L).Value <> "" And .Range("H" & L).Value = "" Then ActiveSheet.Range("A" & DL).Value = .Range("H6").Value: ActiveSheet.Range("B" & DL).Value = .Range("C8").Value: ActiveSheet.Range("C" & DL).Value = .Range("B12").Value: ActiveSheet.Range("D" & DL).Value = .Range("A" & L).Value: ActiveSheet.Range("E" & DL).Value = .Range("C" & L).Value: ActiveSheet.Range("F" & DL).Value = .Range("D" & L).Value: ActiveSheet.Range("G" & DL).Value = .Range("G" & L).Value: ActiveSheet.Range("H" & DL).Value = .Range("E" & L).Value: DL = DL + 1
    
        Next L
  
    
    End With
   
Next i

    Range("A2:H2").Select
    Selection.AutoFilter
     Columns("A:H").Select
    ActiveWindow.Zoom = True
    Range("I1").Select
End Sub

Dranreb · 30 Juillet 2013

Re : Encore ces sacrées boucles !

Bonjour.
Vous avez été un peu long à appliquer la moitié de ma recommandation, non ? N'y auriez vous pas cru ?
J'ignore pourquoi le lien ne se met pas en place. Il me faudrait pouvoir faire des essais sur le fichier joint. Peut être y aurait il lieu de supprimer préalablement les liens préexistants.
La ligne serait plus courte avec des instructions de la forme Me.Cells(DL, "D").Value = .Cells(L, "A").Value
Le mot clé Me désigne toujours l'objet qui porte le code, en l'occurrence la feuille dont c'est la Worksheet_Activate.
Cela dit vous pourriez aussi mettre une affectation par ligne, la première n'étant déjà plus juste derrière le Then, et mettre un End If derrière l'incrémentation de DL.
Vous pourriez avoir intérêt à travailler avec des tableaux: vous y gagneriez en rapidité.

WDAndCo · 30 Juillet 2013

Re : Encore ces sacrées boucles !

Bonjour le Forum, merci Dranreb

Voici la dernière mouture

Code:

Private Sub Worksheet_Activate()
    [A1:I1000].ClearContents
Range("A1").Value = "RECAPITULATIF des Visites EF 5A n°7"
Range("A2").Value = "N° du CR"
Range("B2").Value = "Dates"
Range("C2").Value = "Lieux"
Range("D2").Value = "N° Points"
Range("E2").Value = "Installations"
Range("F2").Value = "Points à Amortir"
Range("G2").Value = "Delais"
Range("H2").Value = "Moyen"

DL = 3 'DL = Derniere Ligne

    For I = 5 To Sheets.Count 'Tous les onglets a partir du 5eme
    
    nf = Sheets(I).Name
      ActiveSheet.Hyperlinks.Add Anchor:=Cells(I - 2, 1), Address:="", SubAddress:="'" & _
         nf & "'" & "!A1", TextToDisplay:=nf
    
        With Sheets(I)
    
      NL = .Range("L1").Value 'NL est egal le nombre de ligne sur l'onglet
       
            For L = 12 To NL + 11 'De la 1er a la derniere avec le decalage
        
            If .Range("G" & L).Value <> "" And .Range("H" & L).Value = "" Then
            ActiveSheet.Range("A" & DL).Value = .Range("H6").Value
            ActiveSheet.Range("B" & DL).Value = .Range("C8").Value
            ActiveSheet.Range("C" & DL).Value = .Range("B12").Value
            ActiveSheet.Range("D" & DL).Value = .Range("A" & L).Value
            ActiveSheet.Range("E" & DL).Value = .Range("C" & L).Value
            ActiveSheet.Range("F" & DL).Value = .Range("D" & L).Value
            ActiveSheet.Range("G" & DL).Value = .Range("G" & L).Value
            ActiveSheet.Range("H" & DL).Value = .Range("E" & L).Value
            DL = DL + 1
    
                End If ' Sinon reprends ici
    
            Next L
        
        End With
    
    Next I

    Range("A2:H2").Select
    Selection.AutoFilter
     Columns("A:H").Select
    ActiveWindow.Zoom = True
    Range("I1").Select
End Sub

Les derniers soucis sont les liens !
C'est un code que j'ai récupéré est adapté.
Je viens d’apprendre grâce a vous le :

Code:

End If

Pour les liens je pense que :

Code:

  nf = Sheets(I).Name
      ActiveSheet.Hyperlinks.Add Anchor:=Cells(I - 2, 1), Address:="", SubAddress:="'" & _
         nf & "'" & "!A1", TextToDisplay:=nf

N’est pas à sa place, mais ou le mettre ?
Pour le fichier joint impossible pour l'instant car je suis boulot !

Dominique

Dranreb · 30 Juillet 2013

Re : Encore ces sacrées boucles !

Ne dépasseriez vous pas le nombre de liens autorisés dans une feuille à force d'en ajouter des centaines toujours les mêmes sur les mêmes cellules sans jamais détruire les anciens préalablement ?

ChTi160 · 30 Juillet 2013

Re : Encore ces sacrées boucles !

Bonjour Dominique
Bonjour Dranred
Bonjour le forum

je viens de tester le code (Sans Données) et les liens sont bien créés en colonne 1 est sont effectifs.
Pour répondre à l'interrogation de Dranred une question (combien de lien crées tu ainsi ?)

Merci par avance
Amicalement
Jean Marie

ChTi160 · 30 Juillet 2013

Re : Encore ces sacrées boucles !

Re

je viens de me rendre compte d'un problème (si j'ai bien compris Lol)

DL = 3 'DL = Derniere Ligne

For I = 5 To Sheets.Count 'Tous les onglets a partir du 5eme

nf = Sheets(I).Name
ActiveSheet.Hyperlinks.Add Anchor:=Cells(I - 2, 1), Address:="", SubAddress:="'" & _
nf & "'" & "!A1", TextToDisplay:=nf

With Sheets(I)

NL = .Range("L1").Value 'NL est egal le nombre de ligne sur l'onglet

For L = 12 To NL + 11 'De la 1er a la derniere avec le decalage

If .Range("G" & L).Value <> "" And .Range("H" & L).Value = "" Then
ActiveSheet.Range("A" & DL).Value = .Range("H6").Value

DL = 3 ,on met donc le lien en colonne 1 ligne 3 pour la feuille 5 etc
puis dans la boucle L =12 to NL+11 on colle en Range("A" & DL), la valeur de .Range("H6").Value alors que
Cells(I - 2, 1) = Range("A" & DL)

ne peux tu mettre une feuille exemple(Feuil5) avec quelques lignes de données non confidentielles?

en espérant avoir compris lol
Bonne fin de Journée
Amicalement
Jean Marie

ChTi160 · 30 Juillet 2013

Re : Encore ces sacrées boucles !

Re
voila ce que j'ai modifié et qui semble fonctionner

VB:

Private Sub Worksheet_Activate()
Dim Ws_Source As Worksheet
Dim Ws_Cible As Worksheet
Dim DL As Byte
Dim I As Byte
Dim NL As Long
Dim L As Long
      Set Ws_Cible = Me
      Application.ScreenUpdating = False
      With Ws_Cible
            [A1:I1000].ClearContents
            .Range("A1").Value = "RECAPITULATIF des Visites EF 5A n°7"
            .Range("A2").Value = "Liens"      '"N° du CR"
            .Range("B2").Value = "N° du CR"
            .Range("C2").Value = "Dates"
            .Range("D2").Value = "Lieux"
            .Range("E2").Value = "N° Points"
            .Range("F2").Value = "Installations"
            .Range("G2").Value = "Points à Amortir"
            .Range("H2").Value = "Delais"
            .Range("I2").Value = "Moyen"
      End With
      DL = 3      'DL = Derniere Ligne
      For I = 5 To Sheets.Count      'Tous les onglets a partir du 5eme
            Set Ws_Source = Sheets(I)
            With Ws_Source
                  Ws_Cible.Hyperlinks.Add Anchor:=Ws_Cible.Cells(I - 2, 1), Address:="", SubAddress:="'" & _
                          .Name & "'" & "!A1", TextToDisplay:=.Name

                  NL = Sheets(I).Range("L1").Value      'NL est egal le nombre de ligne sur l'onglet

                  For L = 12 To NL + 11      'De la 1er a la derniere avec le decalage

                        If .Range("G" & L).Value <> "" And .Range("H" & L).Value = "" Then
                              Ws_Cible.Range("B" & DL).Value = .Range("H6").Value
                              Ws_Cible.Range("C" & DL).Value = .Range("C8").Value
                              Ws_Cible.Range("D" & DL).Value = .Range("B12").Value
                              Ws_Cible.Range("E" & DL).Value = .Range("A" & L).Value
                              Ws_Cible.Range("F" & DL).Value = .Range("C" & L).Value
                              Ws_Cible.Range("G" & DL).Value = .Range("D" & L).Value
                              Ws_Cible.Range("H" & DL).Value = .Range("G" & L).Value
                              Ws_Cible.Range("I" & DL).Value = .Range("E" & L).Value

                              DL = DL + 1

                        End If      ' Sinon reprends ici

                  Next L

            End With
Next I
      With Ws_Cible
            ActiveWindow.Zoom = 200
            .Range("A2:I2").AutoFilter
      End With
      Application.ScreenUpdating = True
End Sub

Dans l'attente
Amicalement
Jean Marie

WDAndCo · 2 Août 2013

Re : Encore ces sacrées boucles !

Bonjour Dranred, Jean Marie et le Forum

Merci, et pardon pour ce retard.
J'ai résolus le problème.

Le problème était la mauvaise position du lien dans mes boucles !

Encore merci.

Code:

Private Sub Worksheet_Activate()

If MsgBox("Confirmez vous la M.A.J du tableau ?", vbYesNo, "Confirmation") = vbNo Then Exit Sub

    [A2:I1000].ClearContents
Range("A1").Value = "RECAPITULATIF des Visites EF 5A n°7"
Range("A2").Value = "N° du CR"
Range("B2").Value = "Dates"
Range("C2").Value = "Lieux"
Range("D2").Value = "N° Points"
Range("E2").Value = "Installations"
Range("F2").Value = "Points à Amortir"
Range("G2").Value = "Delais"
Range("H2").Value = "Moyen"

DL = 3 'DL = Derniere Ligne

    For I = 5 To Sheets.Count 'Tous les onglets a partir du 5eme
  
    nf = Sheets(I).Name
      
    With Sheets(I)
    
      NL = .Range("L1").Value 'Nb de ligne sur l'onglet
       
    For L = 12 To NL + 11
If .Range("G" & L).Value <> "" And .Range("H" & L).Value = "" Then

ActiveSheet.Hyperlinks.Add Anchor:=Cells(DL, 1), Address:="", SubAddress:="'" & _
         nf & "'" & "!A1", TextToDisplay:=nf
         
    ActiveSheet.Range("B" & DL).Value = .Range("C8").Value
    ActiveSheet.Range("C" & DL).Value = .Range("B12").Value
    ActiveSheet.Range("D" & DL).Value = .Range("A" & L).Value
    ActiveSheet.Range("E" & DL).Value = .Range("C" & L).Value
    ActiveSheet.Range("F" & DL).Value = .Range("D" & L).Value
    ActiveSheet.Range("G" & DL).Value = .Range("G" & L).Value
    ActiveSheet.Range("H" & DL).Value = .Range("E" & L).Value
    DL = DL + 1
    
    End If
    
        Next L
        
    End With
    
Next I

    Range("A2:H2").Select
    Selection.AutoFilter
     Columns("A:H").Select
    ActiveWindow.Zoom = True
    Range("I1").Value = DL
    Range("I1").Select
End Sub

Encore ces sacrées boucles !

WDAndCo

XLDnaute Impliqué

Dranreb

XLDnaute Barbatruc

WDAndCo

XLDnaute Impliqué

Dranreb

XLDnaute Barbatruc

WDAndCo

XLDnaute Impliqué

Dranreb

XLDnaute Barbatruc

ChTi160

XLDnaute Barbatruc

ChTi160

XLDnaute Barbatruc

ChTi160

XLDnaute Barbatruc

WDAndCo

XLDnaute Impliqué

Discussions similaires

Encore ces sacrées boucles !

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Impliqué

Discussions similaires

Privacy & Transparency

Privacy & Transparency