Copier une ligne en fonction d'une cellule

Le 20/11/2019 à 11:27

Bonjour,

Je bloque sur une petite programmation, je m'explique.

En fonction de la référence renseigné dans la cellule B5 ou E5 ou H5 ou K5 de la fiche "Sortie de stock" quand je lance l'action "rechercher" juste en dessous, qu'il aille en fonction de la référence saisie me chercher la ou les lignes correspondantes dans la page "infosSTOCK" (le début des données est en B4 jusqu'à K4) et qu'il me copie ses informations dans ma page "Sortie de stock" à partir de la cellule B10.

Pouvez-vous m'aider ? Je bloque complètement sur cette macro.

Merci d'avance.

8classeurajour.xlsm (152.63 Ko)
Le 20/11/2019 à 12:12

Salut Robin1963,

Il te suffit d'utiliser ça (attention pas les bonnes dimensions de Range) :

Dim CopyRange As Range
Dim PasteRange As Range

        Set CopyRange = ThisWorkbook.Worksheets("infosSTOCK").Range("B4:C4")
        Set PasteRange = ThisWorkbook.Worksheets("Sortie de stock").Range("B4:C4")

        PasteRange.Value2 = CopyRange.Value2

Tu l'adaptes à ton code et ça passe tout seul

Bonne journée,

Baboutz

Le 20/11/2019 à 14:43

Rep

Le 20/11/2019 à 14:59
Baboutz a écrit :

Salut Robin1963,

Il te suffit d'utiliser ça (attention pas les bonnes dimensions de Range) :

Dim CopyRange As Range
Dim PasteRange As Range

        Set CopyRange = ThisWorkbook.Worksheets("infosSTOCK").Range("B4:C4")
        Set PasteRange = ThisWorkbook.Worksheets("Sortie de stock").Range("B4:C4")

        PasteRange.Value2 = CopyRange.Value2

Tu l'adaptes à ton code et ça passe tout seul

Bonne journée,

Baboutz

D'accord merci, mais c'est le copie colle de la ligne en fonction de l'information que je renseigne dans les cellules que j'arrive pas à faire..

C'est à dire, dans la cellule "B5" de la feuille "Sortie de stock" je renseigne un emplacement, genre "A.0.1" je lance la macro puis je veux qu'il aille dans la feuille "InfosSTOCK" me trouver la ligne qui correspond a cette emplacement et qu'il me copie cette ligne dans ma feuille "sortie de stock" à partir de la cellule "B10".

Tu vois ? Je sais pas si je suis très clair.

Le 20/11/2019 à 15:23

C'est très clair.

Une proposition. Code dans le module 3 :

3classeurajour.xlsm (152.69 Ko)

Cordialement,

Baboutz

Le 20/11/2019 à 15:31

Salut

Si je comprend bien ce que tu veux faire c'est récupérer des données par rapport à un type de référence, si les données liées à cette référence sont bien celles que tu souhaites alors tu a le choix de sortir cette référence de ton stock ou non.

Si c'est bien ça je te propose quelque chose dans mon fichier(j'ai rajouté un bouton sur la feuille InfosStock).

Dans tous les cas (si tu comprend le VBA) tu retrouveras une méthode pour récupérer les données par rapport à un type de référence

Dit moi ce que tu en penses

8classeurajour.xlsm (165.64 Ko)
Le 20/11/2019 à 15:34
Baboutz a écrit :

C'est très clair.

Une proposition. Code dans le module 3 :

Classeurajour.xlsm

Cordialement,

Baboutz

C'est exactement ce que je chercher !

Merci beaucoup pour ton aide tu m'enlèves une épine du pieds !

Le 20/11/2019 à 15:43

Si besoin je peux t'expliquer le code !

Le 20/11/2019 à 15:53

Dans le doute (et par ce que j'avais du temps ) voilà le code commenté, dsl s'il y a des fautes de frappes mais j'ai fait ça au plus vite 

Option Explicit

Sub RechercheEmplacement()
Dim temp As String, cpt As Integer, Col As Integer, i As Integer, AfficheResult As String
Dim Message As Integer
Dim LaFeuille As Worksheet
Dim Plage As Range
Dim Donnees As Object
Dim ListeLignes() As String, Couleur As String
Dim Trouve

Debut:

Set LaFeuille = ThisWorkbook.Worksheets("InfosStock") 'La variable LaFeuille représente la feuille InfoStock de ce classeur
'Message prend pour valeur la saisie faite par l'utilisateur
Message = Application.InputBox("Choisir un type de recherche. Tappez le numéro correspondant à la recherche :" & Chr(10) & Chr(10) & _
                                "1 : Par emplacement" & Chr(10) & _
                                "2 : Par PDL" & Chr(10) & _
                                "3 : Par PV" & Chr(10) & _
                                "4 : PC/Autre" & Chr(10) & _
                                "5 : Par prescripteur", "Sortie de stock", Type:=1)
If Message = False Then Exit Sub 'Si rien de saisie alors on s'arrete ici
If Message < 1 Or Message > 5 Then 'Si la saisie n'est pas comprise entre 1 et 5 alors :
    'Un message d'erreur apprait à l'utilisateur
    If MsgBox("Type de recherche invalide", vbCritical + vbRetryCancel, "Erreur") = vbRetry Then GoTo Debut Else Exit Sub
    'Si l'utiliteur recommence, le code reprend à la ligne Debut
End If

If Message = 1 Then Col = 2 'Si la variable Message = 1 alors la variable Col = 2
'Autrement dit, la variable Col va représenter la colonne dans laquelle effectuer la recherhce (2=B)
If Message = 2 Then Col = 3 'Idem
If Message = 3 Then Col = 4 'Idem
If Message = 4 Then Col = 5 'Idem
If Message = 5 Then Col = 8 'Idem

With LaFeuille 'Tout ce qui se passe ci-dessous va se dérouler sur la feuille représentée par LaFeuille
    'La variable Trouve représente la valeur cherchée par l'utilisateur
    Trouve = Application.InputBox("Recherche par " & UCase(.Cells(3, Col)) & " :", "Effectuer une recherche")
    If Trouve = "" Or Trouve = False And Trouve <> "0" Then Exit Sub 'Si l'utilisateur annule la recherche on s'arrete ici
Reset:
    cpt = 0 'Mise à 0 de cpt, cpt va être le conteur de résultat(s) trouvé(s)
    temp = "" 'La variable temp est vide, temp va servir de variable temporaire dans laquelle on va stoké les lignes où se trouve les résultats
    Set Plage = .Range(.Cells(4, Col), .Cells(.Range("B" & .Rows.Count).End(xlUp).Row, Col))
    'La variable Plage représente la plage de cellule dans laquelle effectuer la recherhce
    'Elle est définie par la colonne choisie et le nombre de ligne utilisée dans cette colonne
    For Each Donnees In Plage 'Pour toutes les données se trouvant dans Plage
        If Donnees = Trouve Then 'Si la donnée (valeur stockée dans une cellule) = le critère de recherche alors :
            cpt = cpt + 1 'Le compteur s'incrémente de +1
            'Stockage des lignes dans la varibale temp où se trouve les résultats, les numéro de lignes sont séparées par des "-"
            If temp = "" Then temp = Donnees.Row Else temp = temp & "-" & Donnees.Row
        End If
    Next Donnees
    ListeLignes = Split(temp, "-") 'Isole tout les numéros de ligne compris entre les "-"
    For i = LBound(ListeLignes) To UBound(ListeLignes)
        .Activate 'La feuille représentée par la variable LaFeuille est sélectionnée
        .Cells(ListeLignes(i), Col).Select 'Sélection de la cellule où se trouve le résultat via le numéro de la ligne et la colonne
        Couleur = ActiveCell.Interior.Color 'La variable Couleur prend pour valeur le code couleur de la cellule
        'L'ensemble des cellules de la cellule (de la colonne 2 à 11) sont misent en jaune (pour falicilité le reprérage)
        .Range(.Cells(ActiveCell.Row, 2), .Cells(ActiveCell.Row, 10)).Interior.Color = 913639
        'Un message apprait à l'utilisateur avec les données stockée sur la ligne
        AfficheResult = MsgBox("Résultat " & i + 1 & " sur " & UBound(ListeLignes) + 1 & " dans la cellule " & ActiveCell.Address & Chr(10) & Chr(10) & _
        .Cells(3, 3) & " : " & .Cells(ListeLignes(i), 3) & Chr(10) & _
        .Cells(3, 4) & " : " & .Cells(ListeLignes(i), 4) & Chr(10) & _
        .Cells(3, 5) & " : " & .Cells(ListeLignes(i), 5) & Chr(10) & _
        .Cells(3, 6) & " : " & .Cells(ListeLignes(i), 6) & Chr(10) & _
        .Cells(3, 7) & " : " & .Cells(ListeLignes(i), 7) & Chr(10) & _
        .Cells(3, 8) & " : " & .Cells(ListeLignes(i), 8) & Chr(10) & _
        .Cells(3, 9) & " : " & .Cells(ListeLignes(i), 9) & Chr(10) & _
        .Cells(3, 10) & " : " & .Cells(ListeLignes(i), 10) & Chr(10) & _
        .Cells(3, 11) & " :" & .Cells(ListeLignes(i), 11) & Chr(10) & Chr(10) & _
        UCase("Supprimer cette référence ?"), vbExclamation + vbYesNoCancel, "Résulta(s)")
        .Range(.Cells(ActiveCell.Row, 2), .Cells(ActiveCell.Row, 11)).Interior.Color = Couleur
        If AfficheResult = vbYes Then 'Si l'utilisateur répond "oui" pour supprimer la référence alors :
            'Message de confirmation de suppression
            If MsgBox("Confirmer la suppression de " & .Cells(ListeLignes(i), 2) & " ?", vbCritical + vbYesNo, "Suppressions") = vbYes Then
                'Si OUI alors suppression de la lignes avec décalage vers le haut
                .Range(.Cells(ListeLignes(i), 2), .Cells(ListeLignes(i), 11)).Delete Shift:=xlUp
                GoTo Reset 'Retour à la ligne Reset, si une ligne est supprimée il faut annalyser à noveau toutes les lignes
                'En effets après suppression d'une lignes, les numéros de lignes stockés dans temps se retrouvent décalés
            End If
        End If
        If AfficheResult = vbCancel Then Exit For
    Next i
End With

'Si le compteur est resté à 0 cela veux dire que la recherche n'a pas été concluante, un message apparait pour informer l'utilisateur
If cpt = 0 Then If MsgBox("Aucuns résulats.", vbInformation + vbRetryCancel, "Fin de la recherhce") = vbRetry Then GoTo Debut
'Dans le cas contraire, un message apprait pour précisier que tooutes les données trouvées ont été affichées
If cpt > 0 Then If MsgBox("La recherche est terminée, cliquez sur ""Recommencer"" pour lancer une nouvelle recherhce.", vbInformation + vbRetryCancel, "Fin de la recherche") = vbRetry Then GoTo Debut
End Sub
Le 20/11/2019 à 16:09
GGautier a écrit :

Dans le doute (et par ce que j'avais du temps ) voilà le code commenté, dsl s'il y a des fautes de frappes mais j'ai fait ça au plus vite 

Option Explicit

Sub RechercheEmplacement()
Dim temp As String, cpt As Integer, Col As Integer, i As Integer, AfficheResult As String
Dim Message As Integer
Dim LaFeuille As Worksheet
Dim Plage As Range
Dim Donnees As Object
Dim ListeLignes() As String, Couleur As String
Dim Trouve

Debut:

Set LaFeuille = ThisWorkbook.Worksheets("InfosStock") 'La variable LaFeuille représente la feuille InfoStock de ce classeur
'Message prend pour valeur la saisie faite par l'utilisateur
Message = Application.InputBox("Choisir un type de recherche. Tappez le numéro correspondant à la recherche :" & Chr(10) & Chr(10) & _
                                "1 : Par emplacement" & Chr(10) & _
                                "2 : Par PDL" & Chr(10) & _
                                "3 : Par PV" & Chr(10) & _
                                "4 : PC/Autre" & Chr(10) & _
                                "5 : Par prescripteur", "Sortie de stock", Type:=1)
If Message = False Then Exit Sub 'Si rien de saisie alors on s'arrete ici
If Message < 1 Or Message > 5 Then 'Si la saisie n'est pas comprise entre 1 et 5 alors :
    'Un message d'erreur apprait à l'utilisateur
    If MsgBox("Type de recherche invalide", vbCritical + vbRetryCancel, "Erreur") = vbRetry Then GoTo Debut Else Exit Sub
    'Si l'utiliteur recommence, le code reprend à la ligne Debut
End If

If Message = 1 Then Col = 2 'Si la variable Message = 1 alors la variable Col = 2
'Autrement dit, la variable Col va représenter la colonne dans laquelle effectuer la recherhce (2=B)
If Message = 2 Then Col = 3 'Idem
If Message = 3 Then Col = 4 'Idem
If Message = 4 Then Col = 5 'Idem
If Message = 5 Then Col = 8 'Idem

With LaFeuille 'Tout ce qui se passe ci-dessous va se dérouler sur la feuille représentée par LaFeuille
    'La variable Trouve représente la valeur cherchée par l'utilisateur
    Trouve = Application.InputBox("Recherche par " & UCase(.Cells(3, Col)) & " :", "Effectuer une recherche")
    If Trouve = "" Or Trouve = False And Trouve <> "0" Then Exit Sub 'Si l'utilisateur annule la recherche on s'arrete ici
Reset:
    cpt = 0 'Mise à 0 de cpt, cpt va être le conteur de résultat(s) trouvé(s)
    temp = "" 'La variable temp est vide, temp va servir de variable temporaire dans laquelle on va stoké les lignes où se trouve les résultats
    Set Plage = .Range(.Cells(4, Col), .Cells(.Range("B" & .Rows.Count).End(xlUp).Row, Col))
    'La variable Plage représente la plage de cellule dans laquelle effectuer la recherhce
    'Elle est définie par la colonne choisie et le nombre de ligne utilisée dans cette colonne
    For Each Donnees In Plage 'Pour toutes les données se trouvant dans Plage
        If Donnees = Trouve Then 'Si la donnée (valeur stockée dans une cellule) = le critère de recherche alors :
            cpt = cpt + 1 'Le compteur s'incrémente de +1
            'Stockage des lignes dans la varibale temp où se trouve les résultats, les numéro de lignes sont séparées par des "-"
            If temp = "" Then temp = Donnees.Row Else temp = temp & "-" & Donnees.Row
        End If
    Next Donnees
    ListeLignes = Split(temp, "-") 'Isole tout les numéros de ligne compris entre les "-"
    For i = LBound(ListeLignes) To UBound(ListeLignes)
        .Activate 'La feuille représentée par la variable LaFeuille est sélectionnée
        .Cells(ListeLignes(i), Col).Select 'Sélection de la cellule où se trouve le résultat via le numéro de la ligne et la colonne
        Couleur = ActiveCell.Interior.Color 'La variable Couleur prend pour valeur le code couleur de la cellule
        'L'ensemble des cellules de la cellule (de la colonne 2 à 11) sont misent en jaune (pour falicilité le reprérage)
        .Range(.Cells(ActiveCell.Row, 2), .Cells(ActiveCell.Row, 10)).Interior.Color = 913639
        'Un message apprait à l'utilisateur avec les données stockée sur la ligne
        AfficheResult = MsgBox("Résultat " & i + 1 & " sur " & UBound(ListeLignes) + 1 & " dans la cellule " & ActiveCell.Address & Chr(10) & Chr(10) & _
        .Cells(3, 3) & " : " & .Cells(ListeLignes(i), 3) & Chr(10) & _
        .Cells(3, 4) & " : " & .Cells(ListeLignes(i), 4) & Chr(10) & _
        .Cells(3, 5) & " : " & .Cells(ListeLignes(i), 5) & Chr(10) & _
        .Cells(3, 6) & " : " & .Cells(ListeLignes(i), 6) & Chr(10) & _
        .Cells(3, 7) & " : " & .Cells(ListeLignes(i), 7) & Chr(10) & _
        .Cells(3, 8) & " : " & .Cells(ListeLignes(i), 8) & Chr(10) & _
        .Cells(3, 9) & " : " & .Cells(ListeLignes(i), 9) & Chr(10) & _
        .Cells(3, 10) & " : " & .Cells(ListeLignes(i), 10) & Chr(10) & _
        .Cells(3, 11) & " :" & .Cells(ListeLignes(i), 11) & Chr(10) & Chr(10) & _
        UCase("Supprimer cette référence ?"), vbExclamation + vbYesNoCancel, "Résulta(s)")
        .Range(.Cells(ActiveCell.Row, 2), .Cells(ActiveCell.Row, 11)).Interior.Color = Couleur
        If AfficheResult = vbYes Then 'Si l'utilisateur répond "oui" pour supprimer la référence alors :
            'Message de confirmation de suppression
            If MsgBox("Confirmer la suppression de " & .Cells(ListeLignes(i), 2) & " ?", vbCritical + vbYesNo, "Suppressions") = vbYes Then
                'Si OUI alors suppression de la lignes avec décalage vers le haut
                .Range(.Cells(ListeLignes(i), 2), .Cells(ListeLignes(i), 11)).Delete Shift:=xlUp
                GoTo Reset 'Retour à la ligne Reset, si une ligne est supprimée il faut annalyser à noveau toutes les lignes
                'En effets après suppression d'une lignes, les numéros de lignes stockés dans temps se retrouvent décalés
            End If
        End If
        If AfficheResult = vbCancel Then Exit For
    Next i
End With

'Si le compteur est resté à 0 cela veux dire que la recherche n'a pas été concluante, un message apparait pour informer l'utilisateur
If cpt = 0 Then If MsgBox("Aucuns résulats.", vbInformation + vbRetryCancel, "Fin de la recherhce") = vbRetry Then GoTo Debut
'Dans le cas contraire, un message apprait pour précisier que tooutes les données trouvées ont été affichées
If cpt > 0 Then If MsgBox("La recherche est terminée, cliquez sur ""Recommencer"" pour lancer une nouvelle recherhce.", vbInformation + vbRetryCancel, "Fin de la recherche") = vbRetry Then GoTo Debut
End Sub

Super merci beaucoup pour ton aide et ton temps

Le 21/11/2019 à 11:35

[quote=GGautier post_id=813640 time=1574261599 user_id=59891]

Dans le doute (et par ce que j'avais du temps ) voilà le code commenté, dsl s'il y a des fautes de frappes mais j'ai fait ça au plus vite

J'aurai besoin d'un dernier service si cela ne te dérange pas j'ai adapté cette macro à mon tableau (elle est top) mais j'aimerai que la fenêtre "recherche" avec le choix 1 à 5 puis la saisie disparaisse et qu'à la place quand je lance la macro on passe directement à l'étape avec le surlignage de la ligne correspondant à ce que j'ai renseigné dans la feuille "Sortie de stock" à l'emplacement B5 / E5 ou H5.

Pour que ce soit automatisé.

La suite de la macro avec le surlignage de la ligne correspondant à la recherche c'est parfait.

Si tu pouvais m'aider ca serait top !

Le 22/11/2019 à 09:45

Re,

Dans le même état d"esprit que pour le code précédent (j'ai bien distinguer les deux code pour que tu puisses t'y retrouver plus facilement, modifier et garder que ce que tu à vraiment besoins)

ps : je n'ai pas pris le temps de tester toutes les combinaisons de possibilité de recherche, il est possible qu'il y ai des beugues !

Option Explicit
Dim Plage As Range
Dim Donnees As Object
Dim LaFeuille As Worksheet
Dim temp As String, CritDefaut As String, ListeLignes() As String, Couleur As String, AfficheResult As String
Dim MultiCrit As Integer, Col As Integer, cpt As Integer, i As Integer

Sub RechercheEmplacement()
Dim Message As Integer
Dim Trouve

Debut:

Set LaFeuille = ThisWorkbook.Worksheets("InfosStock") 'La variable LaFeuille représente la feuille InfoStock de ce classeur
RechercheEmplacementMultiCrit

If MultiCrit > 0 And CritDefaut <> "" Then
    If MultiCrit = 1 And CritDefaut <> "" Then GoTo Etape1 Else GoTo Fin
    If MultiCrit > 1 Then If CritDefaut <> "" And cpt = 0 Then GoTo Fin
End If

'Message prend pour valeur la saisie faite par l'utilisateur
Message = Application.InputBox("Choisir un type de recherche. Tappez le numéro correspondant à la recherche :" & Chr(10) & Chr(10) & _
                                "1 : Par emplacement" & Chr(10) & _
                                "2 : Par PDL" & Chr(10) & _
                                "3 : Par PV" & Chr(10) & _
                                "4 : PC/Autre" & Chr(10) & _
                                "5 : Par prescripteur", "Sortie de stock", Type:=1)
If Message = False Then Exit Sub 'Si rien de saisie alors on s'arrete ici
If Message < 1 Or Message > 5 Then 'Si la saisie n'est pas comprise entre 1 et 5 alors :
    'Un message d'erreur apprait à l'utilisateur
    If MsgBox("Type de recherche invalide", vbCritical + vbRetryCancel, "Erreur") = vbRetry Then GoTo Debut Else Exit Sub
    'Si l'utiliteur recommence, le code reprend à la ligne Debut
End If

If Message = 1 Then Col = 2 'Si la variable Message = 1 alors la variable Col = 2
'Autrement dit, la variable Col va représenter la colonne dans laquelle effectuer la recherhce (2=B)
If Message = 2 Then Col = 3 'Idem
If Message = 3 Then Col = 4 'Idem
If Message = 4 Then Col = 5 'Idem
If Message = 5 Then Col = 8 'Idem

Etape1:
With LaFeuille 'Tout ce qui se passe ci-dessous va se dérouler sur la feuille représentée par LaFeuille

    'La variable Trouve représente la valeur cherchée par l'utilisateur
    Trouve = Application.InputBox("Recherche par " & UCase(.Cells(3, Col)) & " :", "Effectuer une recherche", CritDefaut)
    If Trouve = "" Or Trouve = False And Trouve <> "0" Then Exit Sub 'Si l'utilisateur annule la recherche on s'arrete ici
Reset:
    cpt = 0 'Mise à 0 de cpt, cpt va être le conteur de résultat(s) trouvé(s)
    temp = "" 'La variable temp est vide, temp va servir de variable temporaire dans laquelle on va stoké les lignes où se trouve les résultats
    Set Plage = .Range(.Cells(4, Col), .Cells(.Range("B" & .Rows.Count).End(xlUp).Row, Col))
    'La variable Plage représente la plage de cellule dans laquelle effectuer la recherhce
    'Elle est définie par la colonne choisie et le nombre de ligne utilisée dans cette colonne
    For Each Donnees In Plage 'Pour toutes les données se trouvant dans Plage
        If Donnees = Trouve Then 'Si la donnée (valeur stockée dans une cellule) = le critère de recherche alors :
            cpt = cpt + 1 'Le compteur s'incrémente de +1
            'Stockage des lignes dans la varibale temp où se trouve les résultats, les numéro de lignes sont séparées par des "-"
            If temp = "" Then temp = Donnees.Row Else temp = temp & "-" & Donnees.Row
        End If
    Next Donnees
    ListeLignes = Split(temp, "-") 'Isole tout les numéros de ligne compris entre les "-"
    For i = UBound(ListeLignes) To LBound(ListeLignes) Step -1
        .Activate
        .Cells(ListeLignes(i), Col).Select
        Couleur = ActiveCell.Interior.Color
        .Range(.Cells(ActiveCell.Row, 2), .Cells(ActiveCell.Row, 11)).Interior.Color = 913639
        'Un message apprait à l'utilisateur avec les données stockée sur la ligne
        AfficheResult = MsgBox("Résultat " & i + 1 & " sur " & UBound(ListeLignes) + 1 & " dans la cellule " & ActiveCell.Address & Chr(10) & Chr(10) & _
        .Cells(3, 3) & " : " & .Cells(ListeLignes(i), 3) & Chr(10) & _
        .Cells(3, 4) & " : " & .Cells(ListeLignes(i), 4) & Chr(10) & _
        .Cells(3, 5) & " : " & .Cells(ListeLignes(i), 5) & Chr(10) & _
        .Cells(3, 6) & " : " & .Cells(ListeLignes(i), 6) & Chr(10) & _
        .Cells(3, 7) & " : " & .Cells(ListeLignes(i), 7) & Chr(10) & _
        .Cells(3, 8) & " : " & .Cells(ListeLignes(i), 8) & Chr(10) & _
        .Cells(3, 9) & " : " & .Cells(ListeLignes(i), 9) & Chr(10) & _
        .Cells(3, 10) & " : " & .Cells(ListeLignes(i), 10) & Chr(10) & _
        .Cells(3, 11) & " :" & .Cells(ListeLignes(i), 11) & Chr(10) & Chr(10) & _
        UCase("Supprimer cette référence ?"), vbExclamation + vbYesNoCancel, "Résulta(s)")
        .Range(.Cells(ActiveCell.Row, 2), .Cells(ActiveCell.Row, 11)).Interior.Color = Couleur
        If AfficheResult = vbYes Then 'Si l'utilisateur répond "oui" pour supprimer la référence alors :
            'Message de confirmation de suppression
            If MsgBox("Confirmer la suppression de " & .Cells(ListeLignes(i), 2) & " ?", vbCritical + vbYesNo, "Suppressions") = vbYes Then
                'Si OUI alors suppression de la lignes avec décalage vers le haut
                .Range(.Cells(ListeLignes(i), 2), .Cells(ListeLignes(i), 11)).Delete 'Shift:=xlUp
                GoTo Reset
                'En effets après suppression d'une lignes, les numéros de lignes stockés dans temps se retrouvent décalés
            End If
        End If
        If AfficheResult = vbCancel Then Exit Sub
    Next i
End With

Fin:
'Si le compteur est resté à 0 cela veux dire que la recherche n'a pas été concluante, un message apparait pour informer l'utilisateur
If cpt = 0 Then If MsgBox("Aucuns résulats.", vbInformation + vbRetryCancel, "Fin de la recherhce") = vbRetry Then GoTo Debut
'Dans le cas contraire, un message apprait pour précisier que tooutes les données trouvées ont été affichées
If cpt > 0 Then If MsgBox("La recherche est terminée, cliquez sur ""Recommencer"" pour lancer une nouvelle recherhce.", vbInformation + vbRetryCancel, "Fin de la recherche") = vbRetry Then GoTo Debut
End Sub

Private Sub RechercheEmplacementMultiCrit()
Dim Crit1 As String, Crit2 As String, Crit3 As String, Crit4 As String, Crit5 As String
Dim Titre1 As String, Titre2 As String, Titre3 As String, Titre4 As String, Titre5 As String
Dim Validation As String
Dim FeuilleParam As Worksheet
Dim Lig As Integer, TestLig As Integer

Set FeuilleParam = ThisWorkbook.Worksheets("Sortie de stock")

MultiCrit = 0
With FeuilleParam
    Titre1 = .Range("B4"): Crit1 = .Range("B5"): If Crit1 <> "" Then MultiCrit = MultiCrit + 1: If MultiCrit = 1 Then CritDefaut = Crit1: Col = 2
    Titre2 = .Range("E4"): Crit2 = .Range("E5"): If Crit2 <> "" Then MultiCrit = MultiCrit + 1: If MultiCrit = 1 Then CritDefaut = Crit2: Col = 3
    Titre3 = .Range("H4"): Crit3 = .Range("H5"): If Crit3 <> "" Then MultiCrit = MultiCrit + 1: If MultiCrit = 1 Then CritDefaut = Crit3: Col = 4
    Titre4 = .Range("K4"): Crit4 = .Range("K5"): If Crit4 <> "" Then MultiCrit = MultiCrit + 1: If MultiCrit = 1 Then CritDefaut = Crit4: Col = 5
    Titre5 = .Range("N4"): Crit5 = .Range("N5"): If Crit5 <> "" Then MultiCrit = MultiCrit + 1: If MultiCrit = 1 Then CritDefaut = Crit5: Col = 8

    If MultiCrit = 1 Then
        If MsgBox("Il existe un paramètre de recherche par défaut. " & Chr(10) & Chr(10) & _
        "Recherche par " & LaFeuille.Cells(3, Col) & Chr(10) & _
        "Le critère de recherche est : " & CritDefaut & Chr(10) & Chr(10) & _
        UCase("Validez-vous les paramètres de recherche ?"), vbQuestion + vbYesNoCancel, "Paramètres par défaut") = vbNo Then MultiCrit = 0
    End If
End With

If MultiCrit > 1 Then
    Validation = MsgBox("Des paramètres de recherche existent déjà :" & Chr(10) & Chr(10) & _
    Titre1 & " : " & Crit1 & Chr(10) & _
    Titre2 & " : " & Crit2 & Chr(10) & _
    Titre3 & " : " & Crit3 & Chr(10) & _
    Titre4 & " : " & Crit4 & Chr(10) & _
    Titre5 & " : " & Crit5 & Chr(10) & Chr(10) & _
    UCase("Confirmez-vous les paramètres de recherche ?"), vbQuestion + vbYesNoCancel, "Critères recherche par défaut")
    If Validation = vbYes Then
Reset:
        temp = ""
        cpt = 0
        Set Plage = LaFeuille.Range(LaFeuille.Cells(4, 2), LaFeuille.Cells(LaFeuille.Range("A" & LaFeuille.Rows.Count).End(xlUp).Row, Col))
        For Each Donnees In Plage
            TestLig = 0
            If Donnees = CritDefaut Then
                Lig = Donnees.Row
                If Crit1 = "" Then TestLig = TestLig + 1 Else If Crit1 = LaFeuille.Cells(Lig, 2) Then TestLig = TestLig + 1
                If Crit2 = "" Then TestLig = TestLig + 1 Else If Crit2 = LaFeuille.Cells(Lig, 3) Then TestLig = TestLig + 1
                If Crit3 = "" Then TestLig = TestLig + 1 Else If Crit3 = LaFeuille.Cells(Lig, 4) Then TestLig = TestLig + 1
                If Crit4 = "" Then TestLig = TestLig + 1 Else If Crit4 = LaFeuille.Cells(Lig, 5) Then TestLig = TestLig + 1
                If Crit5 = "" Then TestLig = TestLig + 1 Else If Crit5 = LaFeuille.Cells(Lig, 8) Then TestLig = TestLig + 1
            End If
            If TestLig = 5 Then
                If temp = "" Then temp = Lig Else temp = temp & "-" & Lig
                cpt = cpt + 1
            End If
        Next Donnees
        ListeLignes = Split(temp, "-")
        For i = LBound(ListeLignes) To UBound(ListeLignes)
            Lig = ListeLignes(i)
            With LaFeuille
                .Activate
                .Cells(Lig, 2).Select
                Couleur = ActiveCell.Interior.Color
                .Range(.Cells(Lig, 2), .Cells(Lig, 11)).Interior.Color = 913639
                AfficheResult = MsgBox("Résultat " & i + 1 & " sur " & UBound(ListeLignes) + 1 & " dans la cellule " & ActiveCell.Address & Chr(10) & Chr(10) & _
                .Cells(3, 3) & " : " & .Cells(ListeLignes(i), 3) & Chr(10) & _
                .Cells(3, 4) & " : " & .Cells(ListeLignes(i), 4) & Chr(10) & _
                .Cells(3, 5) & " : " & .Cells(ListeLignes(i), 5) & Chr(10) & _
                .Cells(3, 6) & " : " & .Cells(ListeLignes(i), 6) & Chr(10) & _
                .Cells(3, 7) & " : " & .Cells(ListeLignes(i), 7) & Chr(10) & _
                .Cells(3, 8) & " : " & .Cells(ListeLignes(i), 8) & Chr(10) & _
                .Cells(3, 9) & " : " & .Cells(ListeLignes(i), 9) & Chr(10) & _
                .Cells(3, 10) & " : " & .Cells(ListeLignes(i), 10) & Chr(10) & _
                .Cells(3, 11) & " :" & .Cells(ListeLignes(i), 11) & Chr(10) & Chr(10) & _
                UCase("Supprimer cette référence ?"), vbExclamation + vbYesNoCancel, "Résulta(s)")
                .Range(.Cells(ActiveCell.Row, 2), .Cells(ActiveCell.Row, 11)).Interior.Color = Couleur
                If AfficheResult = vbYes Then
                    If MsgBox("Confirmer la suppression de " & .Cells(ListeLignes(i), 2) & " ?", vbCritical + vbYesNo, "Suppressions") = vbYes Then
                        .Range(.Cells(ListeLignes(i), 2), .Cells(ListeLignes(i), 11)).Delete Shift:=xlUp
                        If i = UBound(ListeLignes) Then Exit Sub Else GoTo Reset
                    End If
                End If
                If AfficheResult = vbCancel Then Exit Sub
            End With
        Next i
    End If
    If Validation = vbNo Then CritDefaut = "": MultiCrit = 0
End If

End Sub
Rechercher des sujets similaires à "copier ligne fonction"