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
Bernard_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...
Trier par date Trier par votes
T

tdenis

XLDnaute Nouveau
Yeahou à dit:
et voila, j'avais oublié de tester sur des copies 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.
Code: 
Option Explicit
Private Sub Worksheet_change(ByVal Target As Range)
    Dim Ref_Val, Cellule_en_Cours As Range
    On Error GoTo Gere_Erreurs
    If Not Intersect(Target, Range(Cells(16, 3), Cells(45, 3))) Is Nothing Then
        Application.EnableEvents = False
        For Each Cellule_en_Cours In Intersect(Target, Range(Cells(16, 3), Cells(45, 3)))
            With Cellule_en_Cours
                Select Case .Value
                Case Is = "Materiaux"
                    Range(.Offset(0, 1), .Offset(0, 6)).Interior.ColorIndex = 34
                    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
    If Not Intersect(Target, Range(Cells(16, 4), Cells(45, 4))) Is Nothing Then
        For Each Cellule_en_Cours In Intersect(Target, Range(Cells(16, 4), Cells(45, 4)))
            With Cellule_en_Cours
                If Left(.Value, 16) = "Parquet flottant" Then
                    Ref_Val = Right(.Value, 2)
                    .Offset(0, 1).Value = Worksheets("Ressources materiaux").Cells(1 + Ref_Val, 2).Value
                End If
            End With
        Next Cellule_en_Cours
    End If
    On Error GoTo 0
Gere_Erreurs:
    Application.EnableEvents = True
End Sub
Cliquez pour agrandir...
Bonsoir Yeah,
Je suis bleufé par le code que vous avez crée...
Je vous remercie, je vais analyser la lecture de celui-ci pour le comprendre .... c'est top

Un grand merci ;)
Belle soirée a vous et Soan....;)
Bien à vous
 
Vote positif 0 Vote négatif

Discussions similaires

Nicolas JACQUIN
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
848
Nicolas JACQUIN
Nicolas JACQUIN
T
  • Résolu(e)
XL 2016 macro et feuille protégé
2
Réponses
18
Affichages
476
laurent950
laurent950
M
  • Question
XL 2010 Aide à la suppression d'un produit en double dans un magasin spécifique avec conditions
Réponses
9
Affichages
647
Mody200
M
C
  • Question
XL 2021 Problème de remplissage d'une colonne conditionné à d'autres valeurs
Réponses
2
Affichages
301
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
238
Phil69970
Phil69970
R
  • Question
XL 2019 Demande à la macro de chercher et de remplir automatiquement jusqu'à la dernière valeur
Réponses
1
Affichages
396
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
313
Minus&Cortex
M
G
  • Question
Microsoft 365 Export données
Réponses
4
Affichages
413
GClaire
G
D
  • Question
XL 2010 Valoriser cellule par clic
Réponses
4
Affichages
419
fanch55
fanch55
S
  • Résolu(e)
XL 2019 Problème de remplissage cellule en vba
Réponses
5
Affichages
309
snoopy07
S

Membres actuellement en ligne

1 membres et 56 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 499
Messages
2 110 250
Membres
110 711
dernier inscrit
chmessi