Optimisation Code VBA (parcours page + recup info)

Résolu
jpub Messages postés 43 Date d'inscription   Statut Membre Dernière intervention   -  
jpub Messages postés 43 Date d'inscription   Statut Membre Dernière intervention   -
Bonjour,

je me me permet de vous demander de l'aide pour optimiser une macro.

Pour le moment la macro parcours toutes les feuilles du classeur puis récupère les infos dessus et les copies dans un tableau sur la page Dashboard.


Le problème c'est que je parcours plusieurs fois les feuilles pour récupérer info par info, ce qui prend un temps fou.

Serait - il possible de récup toutes les info en une fois par page ou d'améliorer grandement cette macro ?



Mon code est construit de façon très simple :

Range("C7").Select je sélectionne la 1ère cellule de mon tableau Dasboard
For i = 4 To Sheets.Count je pars de la page 4
ActiveCell.Value = Sheets(i).Range("O10").Copy je copie sur la page la cellule O10
Selection.PasteSpecial Paste:=xlPasteValues je copie sur le dashboard en b7 la cellule O10
ActiveCell.Offset(1, 0).Select
Next i je passe à la page suivante et j'inscrit en C8 


Sub Snamelist()



Range("B7").Select
For i = 4 To Sheets.Count
ActiveCell.Value = Sheets(i).Range("N2").Copy
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select

Next i

Range("C7").Select
For i = 4 To Sheets.Count
ActiveCell.Value = Sheets(i).Range("O10").Copy
Selection.PasteSpecial Paste:=xlPasteValues
ActiveCell.Offset(1, 0).Select
Next i

Range("d7").Select
For i = 4 To Sheets.Count
ActiveCell.Value = Sheets(i).Range("z5").Copy
Selection.PasteSpecial Paste:=xlPasteValues
ActiveCell.Offset(1, 0).Select
Next i

Range("d7").Select
For i = 4 To Sheets.Count
ActiveCell.Value = Sheets(i).Range("z5").Copy
Selection.PasteSpecial Paste:=xlPasteValues
ActiveCell.Offset(1, 0).Select
Next i

Range("d7").Select
For i = 4 To Sheets.Count
ActiveCell.Value = Sheets(i).Range("z6").Copy
Selection.PasteSpecial Paste:=xlPasteValues
ActiveCell.Offset(1, 0).Select
Next i

End Sub



Merci de votre aide

A voir également:

3 réponses

Réponse 1 / 3
jordane45 Messages postés 38486 Date d'inscription   Statut Modérateur Dernière intervention   4 752
 
Bonjour,

Visiblement.. tu fais autant de boucles sur tes feuilles.. que tu as de cellules à récupérer...
De plus.. tu utilises le COPY/PAST .. qui bouffe pas mal de ressources...
Si ton but est juste de "copier" les valeurs, il vaut mieux passer par la méthode "VALUE" des cellules.

Et donc.. si j'ai bien compris ton code.. tu souhaites copier, dans la feuille sur laquelle tu te trouves.. les valeurs présentes dans chaque autre onglet...

Peut être quelque chose du genre : 
Sub Snamelist()
Dim LastR As Long

For i = 4 To Sheets.Count
LastR = Derniere_Ligne(ActiveSheet) + 1
Range("B" & LastR).Value = Sheets(i).Range("N2").Value
Range("C" & LastR).Value = Sheets(i).Range("O10").Value
Range("d" & LastR).Value = Sheets(i).Range("z5").Value
Range("e" & LastR).Value = Sheets(i).Range("z6").Value
Next 'Feuille Suivante



End Sub

Function Derniere_Ligne(Sh As Worksheet) As Long
Derniere_Ligne = Sh.Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
End Function



Avant de poser une question, merci de lire la charte du site.
Cordialement, Jordane
0
Réponse 2 / 3
jpub Messages postés 43 Date d'inscription   Statut Membre Dernière intervention   1
 
Bonjour

Et merci de ton aide.

J'ai cependant un petit problème, si je lance plusieurs fois la macro de suite, les mm infos se retrouvent dans le même tableau les une en dessous des autres, que me conseilles-tu :

- dois-je effacer le tableau à l'ouverture du fichier et lancer la macro (+ un un bouton de refresh qui ferait la mm chose) ?

- ou dois-je faire en sorte de sauter les entrées déjà existante et de ne lire que celle qui n'existe pas ? (auquel cas je ne sais pas du tout comment faire ? )

De plus je voudrais faire un lien vers chaque page j'ai donc rajouter une ligne mais bien sur ça ne marche pas 


Sub Snamelist()
Dim LastR As Long

For i = 4 To Sheets.Count
LastR = Derniere_Ligne(ActiveSheet) + 1
Range("B" & LastR).Hyperlinks.Add Anchor = Sheets(i).Range("N2"), Address:="", SubAddress:="", TextToDisplay:=""
Range("C" & LastR).Value = Sheets(i).Range("O10").Value
Range("d" & LastR).Value = Sheets(i).Range("z5").Value
Range("e" & LastR).Value = Sheets(i).Range("z6").Value
Next 'Feuille Suivante



End Sub

Function Derniere_Ligne(Sh As Worksheet) As Long
Derniere_Ligne = Sh.Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
End Function


Merci
0
jordane45 Messages postés 38486 Date d'inscription   Statut Modérateur Dernière intervention   4 752
 
Bonjour,

Perso.. je prendrai le choix 1
- dois-je effacer le tableau à l'ouverture du fichier et lancer la macro (+ un un bouton de refresh qui ferait la mm chose) ?
0
jpub Messages postés 43 Date d'inscription   Statut Membre Dernière intervention   1
 
Bonjour,

Merci de ton aide et de ton conseil,

je mettrais le code final dès que possible.

J'ai une dernière question :

Comment faire pour rajouter un lien vers les pages, j'ai essaué le code suivant mais ça ne marche pas, peut être aurais-tu la solution 
Sub Snamelist()
Dim LastR As Long

For I = 4 To Sheets.Count
LastR = Derniere_Ligne(ActiveSheet) + 1
Range("B" & LastR).Hyperlinks.Add Anchor = Sheets(I).Range("N2").Value, Address:="", TextToDisplay:=Valeur
Range("C" & LastR).Value = Sheets(I).Range("O10").Value
Range("d" & LastR).Value = Sheets(I).Range("z5").Value
Range("e" & LastR).Value = Sheets(I).Range("z6").Value
Next 'Feuille Suivante



End Sub

Function Derniere_Ligne(Sh As Worksheet) As Long
Derniere_Ligne = Sh.Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
End Function
0
jordane45 Messages postés 38486 Date d'inscription   Statut Modérateur Dernière intervention   4 752 > jpub Messages postés 43 Date d'inscription   Statut Membre Dernière intervention  
 
Essayes ça : 

Sub Snamelist()
Dim LastR As Long
Dim subAss As String
Dim valCell As String

For I = 4 To Sheets.Count
subAdd = Sheets(I).Name & "!N2"
valCell = Sheets(I).Range("N2").Value
LastR = Derniere_Ligne(ActiveSheet) + 1
    ActiveSheet.Hyperlinks.Add Anchor:=Range("B" & LastR), Address:="", SubAddress:= _
        subAdd, TextToDisplay:=valCell
Range("C" & LastR).Value = Sheets(I).Range("O10").Value
Range("d" & LastR).Value = Sheets(I).Range("z5").Value
Range("e" & LastR).Value = Sheets(I).Range("z6").Value
Next 'Feuille Suivante

End Sub
0
pijaku Messages postés 12263 Date d'inscription   Statut Modérateur Dernière intervention   2 761
 
Bonjour,

Lorsque vous placez du code sur notre forum, merci d'utiliser les balises code à votre disposition.
Le mode d'emploi (au cas ou) est ICI.

Cordialement,
Pijaku
0
jpub Messages postés 43 Date d'inscription   Statut Membre Dernière intervention   1
 
Bonjour,

Merci pour l'info, je ferais plus attention,
mais quel code pour VB VBA ?
0
Réponse 3 / 3
jpub Messages postés 43 Date d'inscription   Statut Membre Dernière intervention   1
 
Bonjour,

Voici donc le code final.


Merci à tous 

Sub Snamelist()

With Sheets("DASHBOARD").ListObjects("Devoirs")
    If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
End With  'Vide le tableau

Sheets("DASHBOARD").Select

Dim LastR As Long
Dim subAss As String
Dim valCell As String
For I = 4 To Sheets.Count

subAdd = Sheets(I).Name & "!N2"
valCell = Sheets(I).Range("N2").Value
LastR = Derniere_Ligne(ActiveSheet) + 1
    ActiveSheet.Hyperlinks.Add Anchor:=Range("C" & LastR), Address:="", SubAddress:=subAdd, TextToDisplay:=valCell 'nom de page + lien 'récupère les noms des onglets, les listes dans le tableau en leur attribuantvers l'onglet en question
Range("B" & LastR).Value = Sheets(I).Range("AH2").Value 'type 'copie dans la colonne B la valeur contenue en AH2 de chaque pages
Range("D" & LastR).Value = Sheets(I).Range("O10").Value 
Range("F" & LastR).Value = Sheets(I).Range("F48").Value 
Range("G" & LastR).Value = Sheets(I).Range("Z5").Value 

Next 'Feuille Suivante

End Sub

Function Derniere_Ligne(Sh As Worksheet) As Long
Derniere_Ligne = Sh.Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
End Function
0