Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL pour MAC lenteur du vba

T

tdenis

XLDnaute Nouveau
Bonsoir le forum,
voila j'ai un onglet devis avec des menus déroulants dans une colonne
ces intitulés vont déclencher dans une autre colonne un choix de matériaux ou de main d'oeuvre.
apres avoir choisi un matériaux j'aimerais que les valeurs des cellules correspondantes au matériaux se mettent dans les cellules adjacentes comme sur le code ci dessous.
mon soucis :
après le choix du matériau c est lent .... et si je rajoute une deuxieme ligne de valeur a ajouter ca beugue encore plus voire aucuns résultats.
Dois je mettre le code find pour éviter les if = valeur ?
merci pour votre aide.

VB: 
Private Sub Worksheet_change(ByVal Target As Range)
    
Dim i As Integer

For i = 16 To 45
If Target.Address = Cells(i, 3) Then
Else
  If Cells(i, 3).Value = "Materiaux" Then

    Range(Cells(i, 4), Cells(i, 9)).Interior.ColorIndex = 34
    Cells(i + 1, 4).Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="='ressources materiaux'!$C$2:$C$100"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
        End With
      If Cells(i + 1, 4).Value = "Parquet flottant 1" Then
        Cells(i + 1, 6).Value = Worksheets("Ressources materiaux").Cells(2, 2).Value
       Else
        If Cells(i + 1, 4).Value = "Parquet flottant 2" Then
        Cells(i + 1, 6).Value = Worksheets("Ressources materiaux").Cells(3, 2).Value
        Else
         End If
         End If
        If Cells(i, 4).Value <> "" Then
      
        
          End If
    
         If Cells(i, 3).Value = "Main d'oeuvre" Then
         Range(Cells(i, 4), Cells(i, 9)).Interior.ColorIndex = 24
            Cells(i + 1, 4).Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="='Main d''oeuvre'!$B$2:$B$100"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
        End With
        Else
             If Cells(i, 3).Value = "Sous-Total" Then
             Range(Cells(i, 4), Cells(i, 8)).Interior.ColorIndex = 18
                Cells(i, 9).Interior.ColorIndex = "0"
        Else
             If Cells(i, 3).Value = "Total" Then
             Range(Cells(i, 4), Cells(i, 8)).Interior.ColorIndex = 24
                Cells(i, 9).Interior.ColorIndex = "0"
        Else
            If Cells(i, 3).Value = "Déplacement" Then
             Range(Cells(i, 4), Cells(i, 9)).Interior.ColorIndex = 44
        Else
            If Cells(i, 3).Value = "" Then
             Range(Cells(i, 2), Cells(i, 9)).Interior.ColorIndex = 2
        Else
            End If
            End If
            End If
            End If
        End If
    End If
End If
Next i
   End Sub
 
Solution
et voila, j'avais oublié de tester la copie en sélection multiples, d'où l'intérêt d'un fichier test même basique, on ne le répète jamais assez, voila le code modifié pour gérer le copier coller en sélection multiple.
VB: 
Option Explicit
Private Sub Worksheet_change(ByVal Target As Range)
    Dim Ref_Val, Cellule_en_Cours As Range 'définition des variables, un variant, un range
    On Error GoTo Gere_Erreurs 'si erreur va à Gere_Erreurs
    If Not Intersect(Target, Range(Cells(16, 3), Cells(45, 3))) Is Nothing Then 'exécute le code si intersection target et C16:C45
        Application.EnableEvents = False 'désactivation des événements, changer des cellules ne relance pas la sub change
        For Each Cellule_en_Cours In...
Trier par date Trier par votes

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter XLD
Bonsoir Tdenis, le forum

J'ai essayé de nettoyer ton code mais sans fichier exemple, je ne comprends pas pourquoi tu boucles comme cela sur tes cellules. à chaque changement d'une cellule, tu appliques sur toutes les cellules concernées, de plus récursif car tu appliques des changements dans un événement change.
enfin voila ton code modifié mais non testé, cela devrait être plus rapide et éviter la récursivité avec Stop_Change (on peut aussi le faire avec application.enableevents = false en n'oubliant surtout pas de mettre application.enableevents = true après Gere_Erreurs: pour rétablir les événements en cas d'erreur.(voir deuxième proc)

VB: 
Dim Stop_Change As Boolean

Private Sub Worksheet_change(ByVal Target As Range)
    If Stop_Change Then Exit Sub
    Dim i%, y%, z%
    y = 16: z = 45
    If Not Intersect(Target, Range(Cells(y, 3), Cells(z, 3))) Is Nothing Then
        On Error GoTo Gere_Erreurs
        Stop_Change = True
        For i = 16 To 45
            Select Case Cells(i, 3).Value
            Case Is = "Materiaux"
                Range(Cells(i, 4), Cells(i, 9)).Interior.ColorIndex = 34
                With Cells(i + 1, 4).Validation
                    .Delete
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                    xlBetween, Formula1:="='ressources materiaux'!$C$2:$C$100"
                    .IgnoreBlank = True
                    .InCellDropdown = True
                    .InputTitle = ""
                    .ErrorTitle = ""
                    .InputMessage = ""
                    .ErrorMessage = ""
                    .ShowInput = True
                    .ShowError = True
                End With
                If Cells(i + 1, 4).Value = "Parquet flottant 1" Then
                    Cells(i + 1, 6).Value = Worksheets("Ressources materiaux").Cells(2, 2).Value
                Else
                    If Cells(i + 1, 4).Value = "Parquet flottant 2" Then
                        Cells(i + 1, 6).Value = Worksheets("Ressources materiaux").Cells(3, 2).Value
                    End If
                End If
            Case Is = "Main d'oeuvre"
                Range(Cells(i, 4), Cells(i, 9)).Interior.ColorIndex = 24
                With Cells(i + 1, 4).Validation
                    .Delete
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                    xlBetween, Formula1:="='Main d''oeuvre'!$B$2:$B$100"
                    .IgnoreBlank = True
                    .InCellDropdown = True
                    .InputTitle = ""
                    .ErrorTitle = ""
                    .InputMessage = ""
                    .ErrorMessage = ""
                    .ShowInput = True
                    .ShowError = True
                End With
            Case Is = "Sous-Total"
                Range(Cells(i, 4), Cells(i, 8)).Interior.ColorIndex = 18
                Cells(i, 9).Interior.ColorIndex = "0"
            Case Is = "Total"
                Range(Cells(i, 4), Cells(i, 8)).Interior.ColorIndex = 24
                Cells(i, 9).Interior.ColorIndex = "0"
            Case Is = "Déplacement"
                Range(Cells(i, 4), Cells(i, 9)).Interior.ColorIndex = 44
            Case Is = ""
                Range(Cells(i, 2), Cells(i, 9)).Interior.ColorIndex = 2
            Case Else
            End Select
        Next i
End if
Gere_Erreurs:
    Stop_Change = False
End Sub
mais à mon avis, il peut être remplacé avantageusement par celui la, toujours non testé faute de fichier
VB: 
Private Sub Worksheet_change(ByVal Target As Range)
     If Not Intersect(Target, Range(Cells(16, 3), Cells(45, 3))) Is Nothing Then
        On Error GoTo Gere_Erreurs
        Application.EnableEvents = False
        Select Case Target.Value
        Case Is = "Materiaux"
            Range(Target.Offset(0, 1), Target.Offset(0, 6)).Interior.ColorIndex = 34
            With Target.Offset(1, 1).Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:="='ressources materiaux'!$C$2:$C$100"
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
            If Target.Offset(1, 1).Value = "Parquet flottant 1" Then
                Target.Offset(1, 3).Value = Worksheets("Ressources materiaux").Cells(2, 2).Value
            Else
                If Target.Offset(1, 1).Value = "Parquet flottant 2" Then
                    Target.Offset(1, 3).Value = Worksheets("Ressources materiaux").Cells(3, 2).Value
                End If
            End If
        Case Is = "Main d'oeuvre"
            Range(Target.Offset(0, 1), Target.Offset(0, 6)).Interior.ColorIndex = 24
            With Target.Offset(1, 1).Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:="='Main d''oeuvre'!$B$2:$B$100"
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
        Case Is = "Sous-Total"
            Range(Target.Offset(0, 1), Target.Offset(0, 5)).Interior.ColorIndex = 18
            Target.Offset(0, 6).Interior.ColorIndex = "0"
        Case Is = "Total"
            Range(Target.Offset(0, 1), Target.Offset(0, 5)).Interior.ColorIndex = 24
            Target.Offset(0, 6).Interior.ColorIndex = "0"
        Case Is = "Déplacement"
            Range(Target.Offset(0, 1), Target.Offset(0, 6)).Interior.ColorIndex = 44
        Case Is = ""
            Range(Target.Offset(0, -1), Target.Offset(0, 6)).Interior.ColorIndex = 2
        Case Else
        End Select
End if
Gere_Erreurs:
    Application.EnableEvents = True
End Sub

Avec un fichier exemple, on pourrait sans aucun doute faire beaucoup plus et mieux !
Habituellement, je ne t'aurai pas répondu sans fichier mais j'étais de bonne humeur et confiné, mais je n'irai pas plus loin sans, c'est déjà pas mal vu ma signature !

Bien cordialement, @+
 
Dernière édition:
Vote positif 0 Vote négatif
T

tdenis

XLDnaute Nouveau
Bonsoir à vous deux,
Yeahou, vos codes ne fonctionnent pas sur les appels a parquet flottant 1, 2 pour renvoyer les valeurs de cellules.
En même temps je me pose la question si je ne dois pas faire une variante sur la correspondance.
au lieu de dire si la cellule est égale à parquet flottant 1 je revoie la valeur des cellules correspondantes , à la place je mets si la cellule est différente de "" je vais chercher la valeur exacte dans une plage dans l'onglet matériaux et faire correspondre les valeurs de cette recherche ..
qu'en pensez vous ?
Mon fichier est trop volumineux pour le mettre en pièce jointe...
merci pour aide ou au moins une orientation de code.
Thierry
 
Vote positif 0 Vote négatif
S

soan

XLDnaute Barbatruc
Inactif
Bonsoir Thierry, Yeahou,

recommandation expresse du pénitencier de l'Oklahoma : la construction de cellules est fortement déconseillée sur des parquets flottants : les Dalton peuvent creuser leur tunnel beaucoup trop facilement, et les télégrammes pour avertir Luky Luke de leur évasion commencent à ruiner les finances de l'État ! rassure-moi : tu veux quand même pas mettre Abraham Lincoln sur la paille ? ​

soan
 
Vote positif 0 Vote négatif

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter XLD
@soan , tu sais, il y en a qui bossent ! (même si ils sont retraités)

@tdenis
Voila, je crois avoir compris (même une simple visu d'une feuille, ça aide), il faut séparer les événements change

VB: 
Private Sub Worksheet_change(ByVal Target As Range)
    On Error GoTo Gere_Erreurs
    If Not Intersect(Target, Range(Cells(16, 3), Cells(45, 3))) Is Nothing Then
        Application.EnableEvents = False
        Select Case Target.Value
        Case Is = "Materiaux"
            Range(Target.Offset(0, 1), Target.Offset(0, 6)).Interior.ColorIndex = 34
            With Target.Offset(1, 1).Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:="='ressources materiaux'!$C$2:$C$100"
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
        Case Is = "Main d'oeuvre"
            Range(Target.Offset(0, 1), Target.Offset(0, 6)).Interior.ColorIndex = 24
            With Target.Offset(1, 1).Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:="='Main d''oeuvre'!$B$2:$B$100"
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
        Case Is = "Sous-Total"
            Range(Target.Offset(0, 1), Target.Offset(0, 5)).Interior.ColorIndex = 18
            Target.Offset(0, 6).Interior.ColorIndex = "0"
        Case Is = "Total"
            Range(Target.Offset(0, 1), Target.Offset(0, 5)).Interior.ColorIndex = 24
            Target.Offset(0, 6).Interior.ColorIndex = "0"
        Case Is = "Déplacement"
            Range(Target.Offset(0, 1), Target.Offset(0, 6)).Interior.ColorIndex = 44
        Case Is = ""
            Range(Target.Offset(0, -1), Target.Offset(0, 6)).Interior.ColorIndex = 2
        Case Else
        End Select
    End If
    Application.EnableEvents = True
    If Not Intersect(Target, Range(Cells(16, 4), Cells(45, 4))) Is Nothing Then
        Select Case Target.Value
        Case Is = "Parquet flottant 1"
            Target.Offset(0, 1).Value = Worksheets("Ressources materiaux").Cells(2, 2).Value
        Case Is = "Parquet flottant 2"
            Target.Offset(0, 1).Value = Worksheets("Ressources materiaux").Cells(3, 2).Value
        Case Is = "Parquet flottant 2"
            Target.Offset(0, 1).Value = Worksheets("Ressources materiaux").Cells(4, 2).Value
        Case Is = "Parquet flottant 3"
            Target.Offset(0, 1).Value = Worksheets("Ressources materiaux").Cells(5, 2).Value
        Case Is = "Parquet flottant 4"
            Target.Offset(0, 1).Value = Worksheets("Ressources materiaux").Cells(6, 2).Value
        Case Is = "Parquet flottant 5"
            Target.Offset(0, 1).Value = Worksheets("Ressources materiaux").Cells(7, 2).Value
        Case Is = "Parquet flottant 6"
            Target.Offset(0, 1).Value = Worksheets("Ressources materiaux").Cells(8, 2).Value
        Case Is = "Parquet flottant 7"
            Target.Offset(0, 1).Value = Worksheets("Ressources materiaux").Cells(9, 2).Value
        Case Else
        End Select
    End If
    On Error GoTo 0
Gere_Erreurs:
    Application.EnableEvents = True
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter XLD
il y a plein de solutions possibles, pour ma part, j'utiliserai un dico, c'est l'idéal pour retrouver la correspondance entre deux valeurs. sinon un recherchev fera l'affaire en modifiant un peu l'organisation de vos données. Vous pouvez aussi utiliser un tableau, ou des select case comme dans l'exemple que je viens de modifier ou, le moins pratique, des if then else imbriqués
 
Vote positif 0 Vote négatif

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter XLD
et voila, j'avais oublié de tester la copie en sélection multiples, d'où l'intérêt d'un fichier test même basique, on ne le répète jamais assez, voila le code modifié pour gérer le copier coller en sélection multiple.
VB: 
Option Explicit
Private Sub Worksheet_change(ByVal Target As Range)
    Dim Ref_Val, Cellule_en_Cours As Range 'définition des variables, un variant, un range
    On Error GoTo Gere_Erreurs 'si erreur va à Gere_Erreurs
    If Not Intersect(Target, Range(Cells(16, 3), Cells(45, 3))) Is Nothing Then 'exécute le code si intersection target et C16:C45
        Application.EnableEvents = False 'désactivation des événements, changer des cellules ne relance pas la sub change
        For Each Cellule_en_Cours In Intersect(Target, Range(Cells(16, 3), Cells(45, 3))) 'pour chaque cellule de l'intersection
            With Cellule_en_Cours 'avec la cellule en cours
                Select Case .Value 'selon la valeur de la cellule en cours
                Case Is = "Materiaux" 'exécute le code jusqu'au prochaine case si cellule en cours = valeur puis va à end select
                    Range(.Offset(0, 1), .Offset(0, 6)).Interior.ColorIndex = 34 'les offset décalent à partir de la cellule en cours
                    With .Offset(1, 1).Validation
                        .Delete
                        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                        xlBetween, Formula1:="='ressources materiaux'!$C$2:$C$100"
                        .IgnoreBlank = True
                        .InCellDropdown = True
                        .InputTitle = ""
                        .ErrorTitle = ""
                        .InputMessage = ""
                        .ErrorMessage = ""
                        .ShowInput = True
                        .ShowError = True
                    End With
                Case Is = "Main d'oeuvre"
                    Range(.Offset(0, 1), .Offset(0, 6)).Interior.ColorIndex = 24
                    With .Offset(1, 1).Validation
                        .Delete
                        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                        xlBetween, Formula1:="='Main d''oeuvre'!$B$2:$B$100"
                        .IgnoreBlank = True
                        .InCellDropdown = True
                        .InputTitle = ""
                        .ErrorTitle = ""
                        .InputMessage = ""
                        .ErrorMessage = ""
                        .ShowInput = True
                        .ShowError = True
                    End With
                Case Is = "Sous-Total"
                    Range(.Offset(0, 1), .Offset(0, 5)).Interior.ColorIndex = 18
                    .Offset(0, 6).Interior.ColorIndex = "0"
                Case Is = "Total"
                    Range(.Offset(0, 1), .Offset(0, 5)).Interior.ColorIndex = 24
                    .Offset(0, 6).Interior.ColorIndex = "0"
                Case Is = "Déplacement"
                    Range(.Offset(0, 1), .Offset(0, 6)).Interior.ColorIndex = 44
                Case Is = ""
                    Range(.Offset(0, -1), .Offset(0, 6)).Interior.ColorIndex = 2
                Case Else
                End Select
            End With
        Next Cellule_en_Cours
    End If
    Application.EnableEvents = True ' on rétablit les événements dès qu'on peut
    If Not Intersect(Target, Range(Cells(16, 4), Cells(45, 4))) Is Nothing Then 'exécute le code si intersection target et D16:D45
        For Each Cellule_en_Cours In Intersect(Target, Range(Cells(16, 4), Cells(45, 4))) 'pour chaque cellule de l'intersection
            With Cellule_en_Cours 'avec la cellule en cours
                If Left(.Value, 16) = "Parquet flottant" Then 'si 16 premier caractères de cellule en cours = "Parquet flottant", exécute le code
                    Ref_Val = Right(.Value, 2) 'Ref_Val en variant prend les deux derniers caractères, soit espace chiffre soit deux chiffres
                    .Offset(0, 1).Value = Worksheets("Ressources materiaux").Cells(1 + Ref_Val, 2).Value 'la cellule en cours prend la valeur du matériau défini, ref_val renvoie un nombre
                End If
            End With
        Next Cellule_en_Cours
    End If
    On Error GoTo 0
Gere_Erreurs: 'routine de gestion d'erreurs
    Application.EnableEvents = True
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
Solution
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
1 K
Nicolas JACQUIN
T
  • Résolu(e)
XL 2016 macro et feuille protégé
2
Réponses
18
Affichages
614
laurent950
P
  • Résolu(e)
XL 2013 EXCEL VBA
Réponses
2
Affichages
330
pangasoul
P
M
  • Question
XL 2010 Aide à la suppression d'un produit en double dans un magasin spécifique avec conditions
Réponses
9
Affichages
736
Mody200
M
S
  • Question
XL 2019 Modifications avec Combobox liées
Réponses
7
Affichages
195
Dranreb
C
  • Question
XL 2021 Problème de remplissage d'une colonne conditionné à d'autres valeurs
Réponses
2
Affichages
374
CathyLD
C
T
  • Question
XL 2016 Erreur d'exécution 1004 : Impossible de définir la propriété Hidden de la classe Range
Réponses
3
Affichages
312
Phil69970
R
  • Question
XL 2019 Demande à la macro de chercher et de remplir automatiquement jusqu'à la dernière valeur
Réponses
1
Affichages
441
Aya_flo
A
M
  • Résolu(e)
XL 2021 PUBLIPOSTAGE : Mise en forme du corps de message issu d'une cellule excel (VBA)
Réponses
4
Affichages
373
Minus&Cortex
M
G
  • Question
Microsoft 365 Export données
Réponses
4
Affichages
455
GClaire
G
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…