Recherche d'une valeur dans un autre classeur puis coller cellule

Bonjour à tous,

Pouvez vous m'aider sur le sujet suivant svp car ma connaissance en VBA est pour le moment basique .

Les deux fichier sont présents sur mon ordinateur dans 2 dossiers différents.

Voici les actions que je voudrais mettre en place:

  • Rechercher les références des colonnes A E et I du classeur "WorkOrder" dans le classeur "Kanban".
  • Une fois la valeur de référence trouvée, copier le lieu de stockage associé depuis le classeur "Kanban" jusqu'au classeur "WorkOrder".
  • Il se peut que certaine références présentes dans "WorkOrder" ne soient pas présentes dans "Kanban". Dans ce cas la passer à la référence suivante de "WorkOrder".

Merci d'avance pour votre aide.

Cordialement,

Aston

11workorder.xlsm (26.71 Ko)
15kanban.xlsx (130.55 Ko)

Bonjour,

Une piste, code à mettre dans un module standard du classeur WorkOrder :

Sub Test()

    Dim ClWO As Workbook
    Dim ClK As Workbook
    Dim PlgWO As Range
    Dim PlgK As Range
    Dim CelWO As Range
    Dim CelK As Range
    Dim Fichier As String

    Set ClWO = ThisWorkbook

    'si le classeur n'est pas ouvert, demande la sélection dans le dossier
    On Error Resume Next
    Set ClK = Workbooks("Kanban.xlsx")

    If Err.Number <> 0 Then

        With Application.FileDialog(3)
            If .Show = -1 Then Fichier = .SelectedItems(1)
        End With

        If Fichier = "" Then Exit Sub

    End If

    On Error GoTo 0

    'défini la plage sur les trois colonnes, A, E et I
    With ClWO.Worksheets("Table 1")

        Set PlgWO = .Range(.Cells(5, 1), .Cells(.Rows.Count, 1).End(xlUp))
        Set PlgWO = Union(PlgWO, .Range(.Cells(5, 5), .Cells(.Rows.Count, 5).End(xlUp)))
        Set PlgWO = Union(PlgWO, .Range(.Cells(5, 9), .Cells(.Rows.Count, 9).End(xlUp)))

    End With

    'défini la plage sur la colonne C
    With ClK.Worksheets("Liste"): Set PlgK = .Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp)): End With

    'effectue la recherche et inscrit la position du stock 3 colonnes plus loin
    For Each CelWO In PlgWO

        CelWO.Value = Trim(CelWO.Value) '<--- les références ont des espaces parasites en début et fin donc, les supprime avant de faire la recherche
        Set CelK = PlgK.Find(CelWO.Value, , xlValues, xlWhole)
        If Not CelK Is Nothing Then CelWO.Offset(, 3).Value = CelK.Offset(, 3).Value

    Next CelWO

End Sub

Merci @Theze pour ta réponse

J'ai essayé ce que tu propose mais j'ai l'erreur en pièce jointe qui s'affiche après la sélection du fichier "Kanban".

Merci d'avance pour ton aide

capture

Oups,

Désolé, j'ai oublié l'instruction pour ouvrir le fichier dans le cas où il ne l'est pas :

Sub Test()

    Dim ClWO As Workbook
    Dim ClK As Workbook
    Dim PlgWO As Range
    Dim PlgK As Range
    Dim CelWO As Range
    Dim CelK As Range
    Dim Fichier As String

    Set ClWO = ThisWorkbook

    'si le classeur n'est pas ouvert, demande la sélection dans le dossier
    On Error Resume Next
    Set ClK = Workbooks("Kanban.xlsx")

    If Err.Number <> 0 Then

        With Application.FileDialog(3)
            If .Show = -1 Then Fichier = .SelectedItems(1)
        End With

        If Fichier = "" Then Exit Sub

    End If

    Set ClK = Workbooks.Open(Fichier) '<--- oublie d'ouvrir le fichier si il n'est pas déjà ouvert !

    On Error GoTo 0

    'défini la plage sur les trois colonnes, A, E et I
    With ClWO.Worksheets("Table 1")

        Set PlgWO = .Range(.Cells(5, 1), .Cells(.Rows.Count, 1).End(xlUp))
        Set PlgWO = Union(PlgWO, .Range(.Cells(5, 5), .Cells(.Rows.Count, 5).End(xlUp)))
        Set PlgWO = Union(PlgWO, .Range(.Cells(5, 9), .Cells(.Rows.Count, 9).End(xlUp)))

    End With

    'défini la plage sur la colonne C
    With ClK.Worksheets("Liste"): Set PlgK = .Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp)): End With

    'effectue la recherche et inscrit la position du stock 3 colonnes plus loin
    For Each CelWO In PlgWO

        CelWO.Value = Trim(CelWO.Value) '<--- les références ont des espaces parasites en début et fin donc, les supprime avant de faire la recherche
        Set CelK = PlgK.Find(CelWO.Value, , xlValues, xlWhole)
        If Not CelK Is Nothing Then CelWO.Offset(, 3).Value = CelK.Offset(, 3).Value

    Next CelWO

End Sub

Merci beaucoup Theze cela fontionne parfaitement et c'est exactement ce que je recherchais

J'aurais une petite question supplémentaire pour ce fichier:

Serait-il possible de fusionner les lignes des références identiques consécutives comme sur la capture d'écran ci-dessous?

Encore un grand merci pour ton aide

capture

Bonjour,

Je ne suis pas fan des fusions de cellules car posent souvent problème mais si c'est ce que tu souhaites !

Ce code ne tien compte que des valeurs identiques en colonnes B, F et J, si les références sont différentes, les cellules seront malgré tout fusionnées. Attention, les cellules ont là aussi des espaces parasites !

Sub Fusionner()

    Dim ClWO As Workbook
    Dim PlgWO As Range
    Dim I As Long

    Set ClWO = ThisWorkbook

    With ClWO.Worksheets("Table 1")

        Set PlgWO = .Range(.Cells(5, 2), .Cells(.Rows.Count, 2).End(xlUp))
        Set PlgWO = Union(PlgWO, .Range(.Cells(5, 6), .Cells(.Rows.Count, 6).End(xlUp)))
        Set PlgWO = Union(PlgWO, .Range(.Cells(5, 10), .Cells(.Rows.Count, 10).End(xlUp)))

    End With

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    For I = PlgWO.Count To 2 Step -1

        If PlgWO(I).Value <> "" Then

            PlgWO(I).Value = Trim(PlgWO(I).Value) '<--- même problème, espaces parasites !

            If PlgWO(I).Value = PlgWO(I - 1).Value Then

                Range(PlgWO(I).Offset(, -1), PlgWO(I - 1).Offset(, -1)).Merge
                Range(PlgWO(I), PlgWO(I - 1)).Merge
                Range(PlgWO(I).Offset(, 1), PlgWO(I - 1).Offset(, 1)).Merge

            End If

        End If

    Next I

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub

Moi aussi je ne suis pas fan des cellules fusionner mais c'est uniquement pour avoir une version imprimable plus aisée à lire

Le code fonctionne bien pour la colonne B mais pour les colonne F et J rien ne se passe. J'ai essayé de regarder ce qui pouvait cloché mais je n'ai pas trouvé.

Une idée?

Merci

Autre petit problème: Je suis obligé d'exécuter la macro 2 fois pour que les cellules se fusionne.

Encore merci pour ton aide

Désolé, la boucle ne tourne que sur la colonne B !

Voici un autre code à tester :

Sub Fusionner()

    Dim ClWO As Workbook
    Dim PlgWO As Range
    Dim TblPlg(1 To 3) As Range
    Dim I As Integer
    Dim J As Long

    Set ClWO = ThisWorkbook

    With ClWO.Worksheets("Table 1")

        Set TblPlg(1) = .Range(.Cells(5, 2), .Cells(.Rows.Count, 2).End(xlUp))
        Set TblPlg(2) = .Range(.Cells(5, 6), .Cells(.Rows.Count, 6).End(xlUp))
        Set TblPlg(3) = .Range(.Cells(5, 10), .Cells(.Rows.Count, 10).End(xlUp))

    End With

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    For I = 3 To 1 Step -1

        For J = TblPlg(I).Count To 2 Step -1

            If TblPlg(I)(J).Value <> "" Then

                'supprime les espaces parasites dans les deux cellules à comparer
                TblPlg(I)(J).Value = Trim(TblPlg(I)(J).Value)
                TblPlg(I)(J - 1).Value = Trim(TblPlg(I)(J - 1).Value)

                If TblPlg(I)(J).Value = TblPlg(I)(J - 1).Value Then

                    Range(TblPlg(I)(J).Offset(, -1), TblPlg(I)(J - 1).Offset(, -1)).Merge
                    Range(TblPlg(I)(J), TblPlg(I)(J - 1)).Merge
                    Range(TblPlg(I)(J).Offset(, 1), TblPlg(I)(J - 1).Offset(, 1)).Merge

                End If

            End If

        Next J

    Next I

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub

Bonjour,

J'ai oublié de répondre à ton interrogation :

Autre petit problème: Je suis obligé d'exécuter la macro 2 fois pour que les cellules se fusionne.

Ceci est dû au fait qu'il y a des espaces parasites donc la première passe supprime les espaces et pour la seconde, les valeurs étant identiques il y a fusion c'est pour ça que j'ai rajouté une ligne de code qui supprime les espaces et dans la cellule en cours et dans la cellule du dessus !

'supprime les espaces parasites dans les deux cellules à comparer
TblPlg(I)(J).Value = Trim(TblPlg(I)(J).Value)
TblPlg(I)(J - 1).Value = Trim(TblPlg(I)(J - 1).Value)

Tout marche parfaitement bien

Tes explication sont très claires et je t'en remercie.

Rechercher des sujets similaires à "recherche valeur classeur puis coller"