USF Recherche a partir de donné dans un autre classeur, modification code

PEX

XLDnaute Occasionnel
bonjour,

comme a l'acoutumer je viens soliciter votre aide.
J'ai défini un userform de recherche par combobox !! le souci est que la macro commence a peser.
Je souhaiterai creer un fichier recherche avec un USF de recherche qui irai chercher les valeurs voulu dans un autre fichier xlms. est-ce possible pour alleger ma macro, ou sinon une correction de ce code est il possible ( car des que je le lance la macro plante le excel complet ) :

Code:
Private Sub quit_Click()
Label_Alerte = ""
Unload Me

End Sub

Private Sub Userform_Initialize()
    Dim Cell As Range
    
With Sheets("outillage")
        For Each Cell In .Range("B2:B" & .Range("B65536").End(xlUp).Row)
            Me.CBoutillage.AddItem (Cell)
        Next
    End With

With Sheets("adhesif")
        For Each Cell In .Range("B2:B" & .Range("B65536").End(xlUp).Row)
            Me.CBadhesif.AddItem (Cell)
        Next
    End With
    
With Sheets("primaire")
        For Each Cell In .Range("B2:B" & .Range("B65536").End(xlUp).Row)
            Me.CBprimaire.AddItem (Cell)
        Next
    End With

With Sheets("sécurité")
        For Each Cell In .Range("B2:B" & .Range("B65536").End(xlUp).Row)
            Me.CBsecurite.AddItem (Cell)
        Next
    End With

With Sheets("consommable outillage")
        For Each Cell In .Range("B2:B" & .Range("B65536").End(xlUp).Row)
            Me.CBconso_outillage.AddItem (Cell)
        Next
    End With

With Sheets("consommable composite")
        For Each Cell In .Range("B2:B" & .Range("B65536").End(xlUp).Row)
            Me.CBconso_composite.AddItem (Cell)
        Next
    End With

With Sheets("tissus sec")
        For Each Cell In .Range("B2:B" & .Range("B65536").End(xlUp).Row)
            Me.CBtissus.AddItem (Cell)
        Next
    End With

With Sheets("prépreg")
        For Each Cell In .Range("B2:B" & .Range("B65536").End(xlUp).Row)
            Me.CBprepreg.AddItem (Cell)
        Next
    End With

With Sheets("résine")
        For Each Cell In .Range("B2:B" & .Range("B65536").End(xlUp).Row)
            Me.CBresine.AddItem (Cell)
        Next
    End With
End Sub

Private Sub save_Click()

    Dim X, occurence As Integer
    Dim R As Range
    Dim ligne As Long
    Dim trouve As Boolean
    
    Dim trouvé As Boolean 'déclare la variable trouvé
    
    
        ThisWorkbook.Sheets("recherche").Range("B2:J" & ThisWorkbook.Sheets("recherche").Range("I:I").End(xlDown).Row).ClearContents
        
        trouve = False
        occurence = 0
        ligne = 2
        Label_Alerte = ""
               
        '=======================================================
        'Recherche parmi les noms de produits securite
        '=======================================================
        Set R = ThisWorkbook.Sheets("sécurité").Range("B:B").Find(What:=CBsecurite.Value, LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not R Is Nothing Then 'condition si au moins une occurrence trouvée
            trouve = True
            For Each R In ThisWorkbook.Sheets("sécurité").Range("B1:B" & ThisWorkbook.Sheets("sécurité").Range("B:B").End(xlDown).Row)
                If R.Text = CBsecurite.Value Then
                    With ThisWorkbook
                         If occurence = 0 Then
                            .Sheets("recherche").Range("B" & ligne).Value = .Sheets("sécurité").Range("B" & R.Row).Value
                            .Sheets("recherche").Range("C" & ligne).Value = .Sheets("sécurité").Range("A" & R.Row).Value
                            .Sheets("recherche").Range("D" & ligne).Value = .Sheets("sécurité").Range("C" & R.Row).Value
                            .Sheets("recherche").Range("E" & ligne).Value = "###########"
                            .Sheets("recherche").Range("F" & ligne).Value = .Sheets("sécurité").Range("E" & R.Row).Value
                            .Sheets("recherche").Range("G" & ligne).Value = "###########"
                            .Sheets("recherche").Range("H" & ligne).Value = "###########"
                            .Sheets("recherche").Range("I" & ligne).Value = "###########"
                            .Sheets("recherche").Range("J" & ligne).Value = .Sheets("sécurité").Range("H" & R.Row).Value
                        End If
          End With
                End If
            Next R
            occurence = 0
        End If
    '=======================================================
    'Recherche parmi les noms de produits outillage
    '=======================================================
       
        ThisWorkbook.Sheets("recherche").Range("B2:J" & ThisWorkbook.Sheets("recherche").Range("I:I").End(xlDown).Row).ClearContents
        
        trouve = False
        occurence = 0
        ligne = 2
        Label_Alerte = ""
        
        Set R = ThisWorkbook.Sheets("outillage").Range("B:B").Find(What:=CBoutillage.Value, LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not R Is Nothing Then 'condition si au moins une occurrence trouvée
            trouve = True
            For Each R In ThisWorkbook.Sheets("outillage").Range("B1:B" & ThisWorkbook.Sheets("outillage").Range("B:B").End(xlDown).Row)
                If R.Text = CBoutillage.Value Then
                    With ThisWorkbook
                         If occurence = 0 Then
                            .Sheets("recherche").Range("B" & ligne).Value = .Sheets("sécurité").Range("B" & R.Row).Value
                            .Sheets("recherche").Range("C" & ligne).Value = .Sheets("sécurité").Range("A" & R.Row).Value
                            .Sheets("recherche").Range("D" & ligne).Value = .Sheets("sécurité").Range("C" & R.Row).Value
                            .Sheets("recherche").Range("F" & ligne).Value = .Sheets("sécurité").Range("D" & R.Row).Value
                            .Sheets("recherche").Range("J" & ligne).Value = .Sheets("sécurité").Range("G" & R.Row).Value
                        End If
          End With
                End If
            Next R
            occurence = 0
        End If
            
        '=======================================================
        'Recherche parmi les noms de produits dans PréPreg
        '=======================================================
            
        ThisWorkbook.Sheets("recherche").Range("B2:J" & ThisWorkbook.Sheets("recherche").Range("I:I").End(xlDown).Row).ClearContents
        
        trouve = False
        occurence = 0
        ligne = 2
        Label_Alerte = ""
        
        Set R = ThisWorkbook.Sheets("prépreg").Range("B:B").Find(What:=TBNumLot.Value, LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not R Is Nothing Then 'condition si au moins une occurrence trouvée
            trouve = True
            For Each R In ThisWorkbook.Sheets("prépreg").Range("B1:B" & ThisWorkbook.Sheets("prépreg").Range("B:B").End(xlDown).Row)
                If R.Text = CBprepreg.Value Then
                    With ThisWorkbook
                         If occurence = 0 Then
                            .Sheets("recherche").Range("B" & ligne).Value = .Sheets("prépreg").Range("B" & R.Row).Value
                            .Sheets("recherche").Range("C" & ligne).Value = .Sheets("prépreg").Range("A" & R.Row).Value
                            .Sheets("recherche").Range("D" & ligne).Value = .Sheets("prépreg").Range("I" & R.Row).Value
                            .Sheets("recherche").Range("E" & ligne).Value = .Sheets("prépreg").Range("J" & R.Row).Value
                            .Sheets("recherche").Range("F" & ligne).Value = .Sheets("prépreg").Range("O" & R.Row).Value
                            .Sheets("recherche").Range("G" & ligne).Value = .Sheets("prépreg").Range("M" & R.Row).Value
                            .Sheets("recherche").Range("H" & ligne).Value = .Sheets("prépreg").Range("D" & R.Row).Value
                            .Sheets("recherche").Range("I" & ligne).Value = .Sheets("prépreg").Range("C" & R.Row).Value
                            .Sheets("recherche").Range("J" & ligne).Value = .Sheets("prépreg").Range("S" & R.Row).Value
                        End If
                            .Sheets("recherche").Range("K" & ligne).Value = .Sheets("prépreg").Range("V" & R.Row).Value
                            .Sheets("recherche").Range("L" & ligne).Value = .Sheets("prépreg").Range("W" & R.Row).Value
                            occurence = occurence + 1
                            ligne = ligne + 1
                    End With
                End If
            Next R
            occurence = 0
        End If
            
        '=======================================================
        'Recherche parmi les noms des Tissu Sec
        '=======================================================
        
        ThisWorkbook.Sheets("recherche").Range("B2:J" & ThisWorkbook.Sheets("recherche").Range("I:I").End(xlDown).Row).ClearContents
        
        Set R = ThisWorkbook.Sheets("tissus sec").Range("B:B").Find(What:=TBNumLot.Value, LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not R Is Nothing Then 'condition si au moins une occurrence trouvée
            trouve = True
            For Each R In ThisWorkbook.Sheets("tissus sec").Range("B1:B" & ThisWorkbook.Sheets("tissus sec").Range("B:B").End(xlDown).Row)
                If R.Text = CBsecurite.Value Then
                    With ThisWorkbook
                         If occurence = 0 Then
                            .Sheets("recherche").Range("B" & ligne).Value = .Sheets("tissus sec").Range("B" & R.Row).Value
                            .Sheets("recherche").Range("C" & ligne).Value = .Sheets("tissus sec").Range("A" & R.Row).Value
                            .Sheets("recherche").Range("D" & ligne).Value = .Sheets("tissus sec").Range("G" & R.Row).Value
                            .Sheets("recherche").Range("G" & ligne).Value = " #Pas de date# "
                            .Sheets("recherche").Range("H" & ligne).Value = .Sheets("tissus sec").Range("D" & R.Row).Value
                            .Sheets("recherche").Range("E" & ligne).Value = .Sheets("tissus sec").Range("H" & R.Row).Value
                            .Sheets("recherche").Range("F" & ligne).Value = .Sheets("tissus sec").Range("I" & R.Row).Value
                            .Sheets("recherche").Range("I" & ligne).Value = .Sheets("tissus sec").Range("C" & R.Row).Value
                            .Sheets("recherche").Range("J" & ligne).Value = .Sheets("tissus sec").Range("N" & R.Row).Value
                        End If
                            .Sheets("recherche").Range("K" & ligne).Value = .Sheets("tissus sec").Range("V" & R.Row).Value
                            .Sheets("recherche").Range("L" & ligne).Value = .Sheets("tissus sec").Range("W" & R.Row).Value
                            occurence = occurence + 1
                            ligne = ligne + 1
                    End With
                End If
            Next R
            occurence = 0
        End If
            
        '=====================================================================
        'Recherche parmi les noms de Consommable Composite
        '=====================================================================
        
        ThisWorkbook.Sheets("recherche").Range("B2:J" & ThisWorkbook.Sheets("recherche").Range("I:I").End(xlDown).Row).ClearContents
        
        Set R = ThisWorkbook.Sheets("consommable composite").Range("B:B").Find(What:=CBconso_composite.Value, LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not R Is Nothing Then 'condition si au moins une occurrence trouvée
            trouve = True
            For Each R In ThisWorkbook.Sheets("consommable composite").Range("B1:B" & ThisWorkbook.Sheets("consommable composite").Range("B:B").End(xlDown).Row)
                If R.Text = CBconso_composite.Value Then
                    With ThisWorkbook
                         If occurence = 0 Then
                            .Sheets("recherche").Range("B" & ligne).Value = .Sheets("consommable composite").Range("B" & R.Row).Value
                            .Sheets("recherche").Range("C" & ligne).Value = .Sheets("consommable composite").Range("A" & R.Row).Value
                            .Sheets("recherche").Range("D" & ligne).Value = .Sheets("consommable composite").Range("H" & R.Row).Value
                            .Sheets("recherche").Range("E" & ligne).Value = .Sheets("consommable composite").Range("I" & R.Row).Value
                            .Sheets("recherche").Range("F" & ligne).Value = .Sheets("consommable composite").Range("K" & R.Row).Value
                            .Sheets("recherche").Range("G" & ligne).Value = .Sheets("consommable composite").Range("F" & R.Row).Value
                            .Sheets("recherche").Range("H" & ligne).Value = .Sheets("consommable composite").Range("D" & R.Row).Value
                            .Sheets("recherche").Range("I" & ligne).Value = .Sheets("consommable composite").Range("C" & R.Row).Value
                            .Sheets("recherche").Range("J" & ligne).Value = .Sheets("consommable composite").Range("N" & R.Row).Value
                        End If
                            .Sheets("recherche").Range("K" & ligne).Value = .Sheets("consommable composite").Range("V" & R.Row).Value
                            .Sheets("recherche").Range("L" & ligne).Value = .Sheets("consommable composite").Range("W" & R.Row).Value
                            occurence = occurence + 1
                            ligne = ligne + 1
                    End With
                End If
            Next R
            occurence = 0
        End If
            
        '=====================================================================
        'Recherche parmi les noms de Consommable outillage
        '=====================================================================
        
        ThisWorkbook.Sheets("recherche").Range("B2:J" & ThisWorkbook.Sheets("recherche").Range("I:I").End(xlDown).Row).ClearContents
        
        Set R = ThisWorkbook.Sheets("consommable outillage").Range("B:B").Find(What:=CBconso_outillage.Value, LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not R Is Nothing Then 'condition si au moins une occurrence trouvée
            trouve = True
            For Each R In ThisWorkbook.Sheets("consommable outillage").Range("B1:B" & ThisWorkbook.Sheets("consommable outillage").Range("B:B").End(xlDown).Row)
                If R.Text = CBconso_outillage.Value Then
                    With ThisWorkbook
                         If occurence = 0 Then
                            .Sheets("recherche").Range("B" & ligne).Value = .Sheets("consommable composite").Range("B" & R.Row).Value
                            .Sheets("recherche").Range("C" & ligne).Value = .Sheets("consommable composite").Range("A" & R.Row).Value
                            .Sheets("recherche").Range("D" & ligne).Value = .Sheets("consommable composite").Range("H" & R.Row).Value
                            .Sheets("recherche").Range("E" & ligne).Value = .Sheets("consommable composite").Range("I" & R.Row).Value
                            .Sheets("recherche").Range("F" & ligne).Value = .Sheets("consommable composite").Range("K" & R.Row).Value
                            .Sheets("recherche").Range("G" & ligne).Value = .Sheets("consommable composite").Range("F" & R.Row).Value
                            .Sheets("recherche").Range("H" & ligne).Value = .Sheets("consommable composite").Range("D" & R.Row).Value
                            .Sheets("recherche").Range("I" & ligne).Value = .Sheets("consommable composite").Range("C" & R.Row).Value
                            .Sheets("recherche").Range("J" & ligne).Value = .Sheets("consommable composite").Range("N" & R.Row).Value
                        End If
                            .Sheets("recherche").Range("K" & ligne).Value = .Sheets("consommable composite").Range("V" & R.Row).Value
                            .Sheets("recherche").Range("L" & ligne).Value = .Sheets("consommable composite").Range("W" & R.Row).Value
                            occurence = occurence + 1
                            ligne = ligne + 1
                    End With
                End If
            Next R
            occurence = 0
        End If
            
        '=======================================================
        'Recherche parmi les noms de Résine
        '=======================================================
        
        ThisWorkbook.Sheets("recherche").Range("B2:J" & ThisWorkbook.Sheets("recherche").Range("I:I").End(xlDown).Row).ClearContents
        
        Set R = ThisWorkbook.Sheets("résine").Range("B:B").Find(What:=CBresine.Value, LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not R Is Nothing Then 'condition si au moins une occurrence trouvée
            trouve = True
            For Each R In ThisWorkbook.Sheets("résine").Range("B1:B" & ThisWorkbook.Sheets("résine").Range("B:B").End(xlDown).Row)
                If R.Text = CBresine.Value Then
                    With ThisWorkbook
                         If occurence = 0 Then
                            .Sheets("recherche").Range("B" & ligne).Value = .Sheets("résine").Range("B" & R.Row).Value
                            .Sheets("recherche").Range("C" & ligne).Value = .Sheets("résine").Range("A" & R.Row).Value
                            .Sheets("recherche").Range("D" & ligne).Value = .Sheets("résine").Range("H" & R.Row).Value
                            .Sheets("recherche").Range("E" & ligne).Value = .Sheets("résine").Range("I" & R.Row).Value
                            .Sheets("recherche").Range("F" & ligne).Value = .Sheets("résine").Range("J" & R.Row).Value
                            .Sheets("recherche").Range("G" & ligne).Value = .Sheets("résine").Range("F" & R.Row).Value
                            .Sheets("recherche").Range("H" & ligne).Value = .Sheets("résine").Range("D" & R.Row).Value
                            .Sheets("recherche").Range("I" & ligne).Value = .Sheets("résine").Range("C" & R.Row).Value
                            .Sheets("recherche").Range("J" & ligne).Value = .Sheets("résine").Range("N" & R.Row).Value
                        End If
                            .Sheets("recherche").Range("K" & ligne).Value = .Sheets("résine").Range("V" & R.Row).Value
                            .Sheets("recherche").Range("L" & ligne).Value = .Sheets("résine").Range("W" & R.Row).Value
                            occurence = occurence + 1
                            ligne = ligne + 1
                    End With
                End If
            Next R
            occurence = 0
        End If
            
        '=======================================================
        'Recherche parmi les noms d'adhesif
        '=======================================================
        
        ThisWorkbook.Sheets("recherche").Range("B2:J" & ThisWorkbook.Sheets("recherche").Range("I:I").End(xlDown).Row).ClearContents
        
        Set R = ThisWorkbook.Sheets("adhesif").Range("B:B").Find(What:=CBadhesif.Value, LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not R Is Nothing Then 'condition si au moins une occurrence trouvée
            trouve = True
            For Each R In ThisWorkbook.Sheets("adhesif").Range("B1:B" & ThisWorkbook.Sheets("adhesif").Range("B:B").End(xlDown).Row)
                If R.Text = CBadhesif.Value Then
                    With ThisWorkbook
                         If occurence = 0 Then
                            .Sheets("recherche").Range("B" & ligne).Value = .Sheets("résine").Range("B" & R.Row).Value
                            .Sheets("recherche").Range("C" & ligne).Value = .Sheets("résine").Range("A" & R.Row).Value
                            .Sheets("recherche").Range("D" & ligne).Value = .Sheets("résine").Range("H" & R.Row).Value
                            .Sheets("recherche").Range("E" & ligne).Value = .Sheets("résine").Range("I" & R.Row).Value
                            .Sheets("recherche").Range("F" & ligne).Value = .Sheets("résine").Range("J" & R.Row).Value
                            .Sheets("recherche").Range("G" & ligne).Value = .Sheets("résine").Range("F" & R.Row).Value
                            .Sheets("recherche").Range("H" & ligne).Value = .Sheets("résine").Range("D" & R.Row).Value
                            .Sheets("recherche").Range("I" & ligne).Value = .Sheets("résine").Range("C" & R.Row).Value
                            .Sheets("recherche").Range("J" & ligne).Value = .Sheets("résine").Range("N" & R.Row).Value
                        End If
                            .Sheets("recherche").Range("K" & ligne).Value = .Sheets("résine").Range("V" & R.Row).Value
                            .Sheets("recherche").Range("L" & ligne).Value = .Sheets("résine").Range("W" & R.Row).Value
                            occurence = occurence + 1
                            ligne = ligne + 1
                    End With
                End If
            Next R
            occurence = 0
        End If
             
               
        '=======================================================
        'Recherche parmi les noms de primaire
        '=======================================================
        
        ThisWorkbook.Sheets("recherche").Range("B2:J" & ThisWorkbook.Sheets("recherche").Range("I:I").End(xlDown).Row).ClearContents
        
        Set R = ThisWorkbook.Sheets("primaire").Range("B:B").Find(What:=CBprimaire.Value, LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not R Is Nothing Then 'condition si au moins une occurrence trouvée
            trouve = True
            For Each R In ThisWorkbook.Sheets("primaire").Range("B1:B" & ThisWorkbook.Sheets("primaire").Range("B:B").End(xlDown).Row)
                If R.Text = CBprimaire.Value Then
                    With ThisWorkbook
                         If occurence = 0 Then
                            .Sheets("recherche").Range("B" & ligne).Value = .Sheets("résine").Range("B" & R.Row).Value
                            .Sheets("recherche").Range("C" & ligne).Value = .Sheets("résine").Range("A" & R.Row).Value
                            .Sheets("recherche").Range("D" & ligne).Value = .Sheets("résine").Range("H" & R.Row).Value
                            .Sheets("recherche").Range("E" & ligne).Value = .Sheets("résine").Range("I" & R.Row).Value
                            .Sheets("recherche").Range("F" & ligne).Value = .Sheets("résine").Range("J" & R.Row).Value
                            .Sheets("recherche").Range("G" & ligne).Value = .Sheets("résine").Range("F" & R.Row).Value
                            .Sheets("recherche").Range("H" & ligne).Value = .Sheets("résine").Range("D" & R.Row).Value
                            .Sheets("recherche").Range("I" & ligne).Value = .Sheets("résine").Range("C" & R.Row).Value
                            .Sheets("recherche").Range("J" & ligne).Value = .Sheets("résine").Range("N" & R.Row).Value
                        End If
                            .Sheets("recherche").Range("K" & ligne).Value = .Sheets("résine").Range("V" & R.Row).Value
                            .Sheets("recherche").Range("L" & ligne).Value = .Sheets("résine").Range("W" & R.Row).Value
                            occurence = occurence + 1
                            ligne = ligne + 1
                    End With
                End If
            Next R
            occurence = 0
        End If
        
         If trouve = False Then
            Label_Alerte = "Aucune information trouvée"
        Else
            ThisWorkbook.Sheets("recherche").Activate
            Unload Me
        End If

End Sub

je pense que je ne devrai pas repeter la ligne :

ThisWorkbook.Sheets("recherche").Range("B2:J" & ThisWorkbook.Sheets("recherche").Range("I:I").End(xlDown).Row).ClearContents


si quelqu'un peut m'aider soit sur ce code VBa soit pour importer des données depuis un autre fichier je suis preneur !

cordialement
 

Discussions similaires

Réponses
0
Affichages
308

Membres actuellement en ligne

Aucun membre en ligne actuellement.

Statistiques des forums

Discussions
314 655
Messages
2 111 605
Membres
111 217
dernier inscrit
aladinkabeya2