Trouver une solution sur un complement de macro

[tinet]

Bonsoir le forum,

je cherche un coup de pouce pour régler le problème de ma macro.
mon classeur possède plusieurs feuilles.
une trentaine de feuilles numérotée de 1 à 32 avec cette fonction.

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Application.Intersect(Target, Range("F1")) Is Nothing Then
Dim Derlig As Long, Critere As String
' Désactivation de l'affichage[/COLOR]
Application.ScreenUpdating = False
' Définition du critère du fournisseur
With Sheets("1")
Critere = .Range("F1").Text
End With
With Sheets("CATALOGUE ACHAT")
.Range("A1:M1").AutoFilter ' Mise en place du filtre automatique
.Range("A1:M1").AutoFilter Field:=12, Criteria1:=Critere ' Filtre
'Effacement des données précédentes
ActiveSheet.Unprotect Password:=Feuil07.Range("A1").Value
Sheets("1").Range("C31:H880,J31:J880,k31:k880").ClearContents
' Copie des valeurs filtrées
Derlig = .Range("B65536").End(xlUp).Row
'If Derlig < 2 Then Exit Sub
.Range("C2:f" & Derlig).Copy
ActiveSheet.Unprotect Password:=Feuil07.Range("A1").Value
Sheets("1").Range("C31").PasteSpecial Paste:=xlPasteValues
.Range("g2:g" & Derlig).Copy
Sheets("1").Range("h31").PasteSpecial Paste:=xlPasteValues
.Range("I2:I" & Derlig).Copy
Sheets("1").Range("J31").PasteSpecial Paste:=xlPasteValues
.Range("J2:J" & Derlig).Copy
Sheets("1").Range("k31").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
' Suppression du filtre automatique
.Range("A1:M1").AutoFilter
End With
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:=Feuil07.Range("A1").Value
' Affichage de la feuille résultat
With Sheets("1")
.Select
.Range("g10").Select

End With
End If

End Sub

la cellule F1 de chaque feuille dispose d'un menu déroulant et qui en fonction du choix recherche des informations sur la feuille" catalogue achat" et copie les informations sur la feuille sélectionnée.

je souhaite créer une macro qui exécuterait à un moment donné cette fonction ci-dessus à la suite de la feuille 1 à 32 en reprenant le choix de la cellule F1 pour chaque feuille.

J'ai une solution mais je dois recopier cette fonction 32 fois à la suite.

 

[Pierrot93]

Re : Trouver une solution sur un complement de macro

Re,

pour ignorer certaines feuilles :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Derlig As Long, Critere As String
If Sh.Name <> "nomfeuille1" Or Sh.Name <> "nomfeuille2" Then
If Not Application.Intersect(Target, Range("F1")) Is Nothing Then
'reste du code
End If
End If
End Sub

bon après midi
@+

 

[tinet]

Re : Trouver une solution sur un complement de macro

Merci Pierrot de ta patience.

je vais essayer tout ça, car j'ai peut-être une idée avec la fonction.

merci bon après-midi à toi aussi