Macro synthese

Annette

XLDnaute Occasionnel
Bonsoir le forum,

Je reviens vers vous pour obtenir de l'aide pour une macro (je suis un peu plus douée pour les formules :)).

Je souhaite par le biais d'une macro, récupérer les données par condition de 31 onglets nommés.
ceci afin d'alléger mon classeur car les formules l'allourdissent drôlement.
En souhaitant avoir été claire.

Si une bonne âme pouvait me proposer une solution :rolleyes:.

Merci pour votre aide.

Cordialement
 

Pièces jointes

  • EssaiAnnette.xlsm
    13.4 KB · Affichages: 35
  • EssaiAnnette.xlsm
    13.4 KB · Affichages: 34
  • EssaiAnnette.xlsm
    13.4 KB · Affichages: 36

Annette

XLDnaute Occasionnel
Re : Macro synthese

A mon code non optimisé, je souhaite y intégrer ce morceau de code pour le RAZ auto dès changement de cellule (en fait juste avant la récupération de données).
Code:
Range("B5:W500").Select
Selection.ClearContents
Range("A1").Select
ActiveWorkbook.Save

Ci-joint mon fichier avec la macro actuelle

Merci pour vos suggestions
 

Pièces jointes

  • Copie de EssaiAnnette.xlsm
    21 KB · Affichages: 23
  • Copie de EssaiAnnette.xlsm
    21 KB · Affichages: 29
  • Copie de EssaiAnnette.xlsm
    21 KB · Affichages: 27

Annette

XLDnaute Occasionnel
Re : Macro synthese

Bonsoir le forum,

Après quelques recherches, je suis arrivée "à fixer mon problème de valeur de cellule".
Maintenant je souhaite y intégrer ce morceau de code pour le RAZ auto dès changement de cellule (en fait juste avant la récupération de données).

Code:
Range("B5:W500").Select
Selection.ClearContents
Range("A1").Select
ActiveWorkbook.Save

Ci-joint mon fichier avec la macro actuelle

Merci pour vos suggestions
 

Pièces jointes

  • Copie de EssaiAnnette.xlsm
    21 KB · Affichages: 22
  • Copie de EssaiAnnette.xlsm
    21 KB · Affichages: 26
  • Copie de EssaiAnnette.xlsm
    21 KB · Affichages: 24

Annette

XLDnaute Occasionnel
Re : Macro synthese

Plusieurs essais plus tard, voici mon code fonctionnel qui suit:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$Y$4" Then
Range("B5:W500").Select
Selection.ClearContents
Range("$A$1").Select
Dim ws As Worksheet, pf As Range, pcopy As Range, dl&, The_Crit$
The_Crit = Range("$Y$4")
For Each ws In Worksheets
If Len(ws.Name) = 2 Then
ws.Range("$B$10:$W$21").AutoFilter 8, The_Crit
Set pf = ws.[_FilterDatabase]
Set pcopy = pf.Offset(1, 0).Resize(pf.Rows.Count - 1).SpecialCells(12)
dl = Sheets("Synthese").Cells(Rows.Count, "I").End(3).Row
pcopy.Copy Sheets("Synthese").Cells(dl + 1, "B")
ws.AutoFilterMode = False
End If
Next
End If
End Sub

Je ne sais pas si il peut être optimisé et si un membre voit une amélioration, je suis preneuse :).

Un grand merci au forum et plus particulièrement à Staple1600.

Cordialement
 

Staple1600

XLDnaute Barbatruc
Re : Macro synthese

Bonsoir à tous

Annette
Un peu de lecture
Ce lien n'existe plus
pour savoir comment faire ceci (by your own ;))
Maintenant je souhaite y intégrer ce morceau de code pour le RAZ auto dès changement de cellule (en fait juste avant la récupération de données).

Edition: désolé pour la collision, pendant que tu postais ton dernier message, je rédigeais le mien ;)

Et une petite cure de régime de code VBA en passant ;)
Code VB:
Sub RAZ()
Sheets("NOMDETAFEUILLE").Range("B5:W500")=Empty
'remplacer NOMDETAFEUILLE par le nom de la feuille concernée pare le RAZ
'nom à mettre entre des " "
End Sub
 
Dernière édition:

Annette

XLDnaute Occasionnel
Re : Macro synthese

Bonsoir,

Staple1600,
Merci pour votre retour mais je rencontre malheureusement un nouveau problème. En adaptant la macro à mon fichier original, une erreur est apparue, à savoir que le filtre ne peut s'effectuer si les feuilles sont protégées.

ws.Range("$B$11:$W$391").AutoFilter 8, The_Crit Code mis en cause


Pourtant, en protégeant mes feuilles, j'ai coché "Sélectionner les cellules déverrouillées" et "Utiliser le filtre automatique".
Ma question est la suivante: Est-il possible d'utiliser cette macro sans déprotéger les feuilles et si oui, quelle est la marche à suivre ?

Merci à tous pour vos suggestions

Cordialement
 
Dernière édition:

Annette

XLDnaute Occasionnel
Re : Macro synthese

Staple1600,

J'ai retenu la leçon et j'ai lancé mon SOS après recherches et tentatives.
Voici mon dernier code que je n'arrive toujours pas à faire fonctionner :mad:.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$I$2" Then
Range("$B$5:$W$500") = Empty
Range("$A$1").Select
Dim ws As Worksheet, pf As Range, pcopy As Range, dl&, The_Crit$
The_Crit = Range("$I$2")
For Each ws In Worksheets
If Len(ws.Name) = 2 Then
ActiveSheets.Unprotect "1"
ws.Range("$B$11:$W$391").AutoFilter 8, The_Crit
Set pf = ws.[_FilterDatabase]
Set pcopy = pf.Offset(1, 0).Resize(pf.Rows.Count - 1).SpecialCells(12)
dl = Sheets("Synthese").Cells(Rows.Count, "I").End(3).Row
pcopy.Copy Sheets("Synthese").Cells(dl + 1, "B")
ws.AutoFilterMode = False
End If
Next
ActiveSheets.Protect "1", True, True, True
End If
End Sub

Auriez-vous des pistes, car je n'ai trouvé que cette solution...

Merci pour vos réponses.

Cordialement
 

Annette

XLDnaute Occasionnel
Re : Macro synthese

Staple1600,

Lorsque vous avez envoyé votre message, je testais la méthode précédemment énoncée et préparais mon message.
Je vais chercher le mot en gras UserInterfaceOnly et reviens si ça bloque.

Cordialement
 

Annette

XLDnaute Occasionnel
Re : Macro synthese

Bonsoir,

La maison mère, vous-même et divers intervenants sur ce forum et ailleurs, il y a effectivement plusieurs explications et/ou exemples mais le fait est que je ne comprends ni la logique, ni le fonctionnement ... Je ne comprends rrrriiiiiiiiiiiiiiiiiiiiiien.
Assez pour moi ce jour, au dodo.

Bonne nuit
 

Staple1600

XLDnaute Barbatruc
Re : Macro synthese

Re

Annette
Au cas ou vous ne dormiez point encore, et puisque vous renâcliez devant l'usage de filtres
Voici , histoire de varier les plaisirs, une macro sans filtre ;)
(qui fait la même chose que la macro précédente)
Code:
Sub bNoFilter4Annette()
Dim ws As Worksheet, j&, dl&, vArr, i As Byte, dli&
j = 0
For Each ws In Worksheets
If Len(ws.Name) = 2 Then
dl = ws.Cells(Rows.Count, "I").End(3).Row
vArr = ws.Range("I11:I" & dl).Value
For i = LBound(vArr) To UBound(vArr)
    With Sheets("Synthese")
    If vArr(i, 1) = .Range("Y4") Then
        dli = .Cells(Rows.Count, "B").End(3)(2).Row
        .Cells(dli + j, "B").Resize(, 22).Value = _
        ws.Cells(10 + i, "B").Resize(, 22).Value
        j = j + 1
    End If
    End With
Next
Erase vArr
End If
Next
End Sub

PS: Pourquoi vous changez l’emplacement du critère en cours de route ? (Y4 auparavant , I2 désormais)
Cela oblige à remanier le code ...:rolleyes:
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Re : Macro synthese

Re

La version événementielle (qui me semble avoir un léger souci, non ?) EDITION: version désormais expurgée du petit souci ;)
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet, dl&, vArr, i As Byte
Application.ScreenUpdating = False
Application.EnableEvents = False
If Target.Address = "$Y$4" Then
Range("B5:W500").ClearContents
For Each ws In Worksheets
If Len(ws.Name) = 2 Then
dl = ws.Cells(Rows.Count, "I").End(3).Row
vArr = ws.Range("I11:I" & dl).Value
For i = LBound(vArr) To UBound(vArr)
    With Sheets("Synthese")
    If vArr(i, 1) = .[Y4] Then
        .Cells(.Cells(Rows.Count, "I").End(3)(2).Row, "B").Resize(, 22).Value = _
        ws.Cells(10 + i, "B").Resize(, 22).Value
    End If
    End With
Next
Erase vArr
End If
Next
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
 
Dernière édition:

Annette

XLDnaute Occasionnel
Re : Macro synthese

Bonjour Staple1600, bonjour le forum,

Staple1600, merci beaucoup pour cette excellente macro qui fonctionne à merveille sur mon fichier test mais qui m'indique une erreur d’exécution 6: dépassement de capacité et quand je debugue la ligne en gras est mise en avant:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet, dl&, vArr, i As Byte
Application.ScreenUpdating = False
Application.EnableEvents = False
If Target.Address = "$I$2" Then
Range("B5:W500").ClearContents
For Each ws In Worksheets
If Len(ws.Name) = 2 Then
dl = ws.Cells(Rows.Count, "I").End(3).Row
vArr = ws.Range("I11:I" & dl).Value
For i = LBound(vArr) To UBound(vArr)
With Sheets("Synthese")
If vArr(i, 1) = .[I2] Then
.Cells(.Cells(Rows.Count, "I").End(3)(2).Row, "B").Resize(, 22).Value = _
ws.Cells(10 + i, "B").Resize(, 22).Value
End If
End With
Next
Erase vArr
End If
Next
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

L'emplacement du critère a effectivement été changé en route car cela me facilitait les choses.
De plus, pour agrémenter la chose, j'ai omis de dire que dans chaque onglet concerné, les tableaux de données sont espacés (empilés avec d'autres données entre) et certaines colonnes contiennent des formules protégées:rolleyes:.
Je pense que ceci peut expliquer cela.

Une petite solution ?

Cordialement
 

Discussions similaires

Réponses
2
Affichages
402

Statistiques des forums

Discussions
311 725
Messages
2 081 943
Membres
101 849
dernier inscrit
florentMIG