XL 2010 Optimiser code VBA Numération Alphanumérique automatique

Jojoye

XLDnaute Nouveau
Bonjour à toutes et à tous,

J’aimerais optimiser ce code pour gagner en vitesse, et pour cela j'aurais besoin d'aide.
Merci d'avance

Au début cela fonctionne assez rapidement, mais plus il y a de réf interne plus il devient lent.
La « Réf interne » se met en place à partir du moment où l’on clique dans une cellule de la colonne « O » puis entrée et si sur la même ligne la cellule de la colonne « B » est vide.

Ci-joint le fichier exemple avec le code VBA
 

Pièces jointes

  • Optimiser le code.xlsm
    529.1 KB · Affichages: 16

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour Jojoye, bonjour le forum,

Je ne pense pas avoir gagné beaucoup de temps mais essaie comme ça :

VB:
Private Sub Worksheet_Change(ByVal Target As Range)

Dim LigSFam As Integer
Dim sousfam As String
Dim RefFamille As String
Dim Secteur As String
Dim Comptage As String
Dim MonDico As Object
Dim c As Range
Dim i As Integer 'Ligne colonne A
Dim j As Integer, l As Byte
Dim DerLigListe As Integer 'Dernière ligne de la colonne A
Dim xx As Integer 'les chiffre de la cellule A
Dim yy As Integer 'valeur de la cellule C
Dim aa As String '2 première lettre de la cellule A'On Error Resume Next
    
If Target.Column = 15 Then
    If Target.Offset(0, -13).Value = "" Then
        LigSFam = Target.Row
        '''Recherche numéro référence
        sousfam = Target.Value
        RefFamille = Target.Offset(0, -1).Value
        Secteur = Target.Offset(0, -2).Value

        Select Case Secteur
            Case "CLIMATISATION"
                premsecteur = "F"
            Case "SAV CHAUFFAGE", "SAV SANITAIRE"
                premsecteur = "D"
            Case "COUVERTURE"
                premsecteur = "T"
            Case "SOLAIRE"
                premsecteur = "C"
            Case Else
                premsecteur = Left(Replace(Secteur, "O", "X"), 1)
        End Select
        
        Select Case RefFamille
            Case "BALLON"
                PremFamille = "BL"
            Case "CHAUDIERE"
                PremFamille = "CD"
            Case "DIVERS"
                PremFamille = "DV"
            Case "FUMEE"
                PremFamille = "FM"
            Case Else
                PremFamille = Left(Replace(RefFamille, "O", "X"), 2)
        End Select
        
        Select Case sousfam
            Case "BALLON"
                PremSFamille = "BL"
            Case "VASE"
                PremSFamille = "VS"
            Case "ACCESSOIRE"
                PremSFamille = "AS"
            Case "COMPTEUR"
                PremSFamille = "CP"
            Case "EQUIPEMENT"
                PremSFamille = "EP"
            Case "PER"
                PremSFamille = "PR"
            Case "VARIA"
                PremSFamille = "VR"
            Case "COFFRET"
                PremSFamille = "CF"
            Case "VERTEO"
                PremSFamille = "VT"
            Case "RELAIS"
                PremSFamille = "RS"
            Case "THERMOCOUPLE"
                PremSFamille = "TC"
            Case "DIVERS"
                PremSFamille = "DV"
            Case "PROFIPRESS"
                PremSFamille = "PF"
            Case Else
                PremSFamille = Left(Replace(sousfam, "O", "X"), 2)
        End Select
            
        rechref = premsecteur & PremFamille & PremSFamille
        If Target.Offset(0, -7).Value = "VIESSMANN" Then
            Target.Offset(0, -13).Value = "VI" & Target.Offset(0, -8).Value
        Else
            Set MonDico = CreateObject("Scripting.Dictionary")
            With Worksheets("Articles")
                For Each c In .Range("B2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row)
                    If Left(c.Value, 2) <> "VI" Then
                        If Not MonDico.exists(c.Value) Then MonDico.Add c.Value, c.Value
                    End If
                Next c
                Sheets("Ref utilisees").Range("A1").Resize(MonDico.Count, 1) = Application.Transpose(MonDico.keys)
            End With
            Set MonDico = Nothing
            DerLigListe = Sheets("Ref utilisees").Range("A" & Rows.Count).End(xlUp).Row
            For i = 1 To DerLigListe
                'aa = Left(Sheets("Ref utilisees").Range("A" & i), 2)
                If Sheets("Ref utilisees").Range("A" & i).Value Like "VI*" Then
                Else
                    Sheets("Ref utilisees").Range("B" & i) = Left(Sheets("Ref utilisees").Range("A" & i), 5)
                End If
            Next i
            Sheets("Ref utilisees").Range("B:B").RemoveDuplicates Columns:=1, Header:=xlNo
            Sheets("Ref utilisees").Range("B:B").Sort Key1:=Sheets("Ref utilisees").Range("B1"), Order1:=xlAscending, Header:=xlNo
            For i = 1 To DerLigListe
                l = Len(Sheets("Ref utilisees").Range("A" & i))
                On Error Resume Next
                j = WorksheetFunction.Match(Left(Sheets("Ref utilisees").Range("A" & i), 5), Sheets("Ref utilisees").Range("B:B"), 0)
                xx = Right(Sheets("Ref utilisees").Range("A" & i), 3)
                yy = Sheets("Ref utilisees").Range("C" & j)
                If yy < xx Then Sheets("Ref utilisees").Range("C" & j) = xx
                j = 0
            Next i
            On Error GoTo 0

            '''Cherche les valeurs sur la feuille "Ref utilisees"
            For Each NombreUtilise In ThisWorkbook.Sheets("Ref utilisees").Range("B1").CurrentRegion.Rows
                If NombreUtilise.Cells(2) = rechref Then
                    ValeurNbrUtilisee = 0
                    ValeurNbrUtilisee = Sheets("Ref utilisees").Cells(NombreUtilise.Row, 3).Value
                    Exit For 'fin recherche
                End If
            Next NombreUtilise
            
            If Application.CountIf(Sheets("Ref utilisees").Range("B:B"), rechref) = False Then
                Comptage = Application.CountIfs(Sheets("Articles").Columns("B"), "*" & rechref & "*") + 1
                Target.Offset(0, -13).Value = premsecteur & PremFamille & PremSFamille & Format(Comptage, "000")
            Else
                Target.Offset(0, -13).Value = premsecteur & PremFamille & PremSFamille & Format(ValeurNbrUtilisee + 1, "000")
            End If
        End If
    Else
        Exit Sub
    End If
End If
End Sub
 

eriiic

XLDnaute Barbatruc
Bonjour à tous,

ce sont les instructions telles que :
VB:
                For Each c In .Range("B2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row)
                    If Left(c.Value, 2) <> "VI" Then
                        If Not MonDico.exists(c.Value) Then MonDico.Add c.Value, c.Value
                    End If
qui te brident. Lire cellule par cellule est très lent.
Lit toute la plage en une fois dans une variable tableau, et travaille avec lui ensuite :
Code:
Dim tmp
tmp= .Range("B2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row).value
For i = 1 to ubound(tmp)
    If Left(tmp(i,1), 2) <> "VI" Then
        'blabla dico
    endif
next i
fait à main levé, il y a peut-être des adaptations à faire.
eric
 

Discussions similaires

Réponses
3
Affichages
268

Statistiques des forums

Discussions
311 711
Messages
2 081 796
Membres
101 817
dernier inscrit
carvajal