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

P

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

M
  • Résolu(e)
XL 2016 Amélioration de code
Réponses
3
Affichages
355
M@xu3L
M
M
  • Question
XL 2010 Calcul possible dans la zone de liste pour le débit et le crédit lors d'une recherche basée sur la zone de texte
Réponses
0
Affichages
420
Mody200
M
G
  • Question
Microsoft 365 Incompatibilité de type - Array
Réponses
2
Affichages
224
guiyom
G
P
  • Résolu(e)
Microsoft 365 Erreur d'exécution "9" :L'indice n'appartient pas à la sélection
Réponses
9
Affichages
964
pelerin65
P
C
  • Question
Autres bug sur une procédure avec textbox contenant un code barre
2
Réponses
15
Affichages
637
TooFatBoy
TooFatBoy
C
  • Résolu(e)
Autres gestion bibliothèque avec lecteur code barre
2
Réponses
21
Affichages
2 K
Chatron
C
R
  • Résolu(e)
XL 2016 Un petit coup de main pour un code VBA
Réponses
11
Affichages
561
ReneDav14000
R
I
  • Question
XL 2016 Modification d'une ligne dans mon code
Réponses
2
Affichages
397
INFINITY100
I
S
  • Question
XL 2019 Problème dans un code vba
Réponses
2
Affichages
418
snoopy07
S
C
  • Question
Autres Enregistrer un code barre dans la cellule avant le titre qui est déja enregistré
Réponses
11
Affichages
491
Chatron
C

Membres actuellement en ligne

14 membres et 140 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
312 207
Messages
2 086 237
Membres
103 162
dernier inscrit
fcfg