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
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
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
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.