Discussion :

[Manu3100]

Bonjour a tous,

Je suis bloque sur un code:
La situation:
1. le code ci dessous check les valeures dans la colonne A de la feuille2 et check si il y a une correspondance dans la colonneA de la feuille1. Si oui alors la ligne de la feuille2 est copier puis coller dans la ligne correspondante de la feuille1.

Le probleme: J'ai plusieurs code dans la meme cellule qui sont separe par des virgules. Il y a t'il un moyen avec VBA pour que le code check tout les codes dans une meme cellule (dans la Feuille2) et check dans la feuille1.

J 'ai essaye d'utilise SPLIT mais je n'y arrive pas. Je suis preneur de toutes idees.

Thanks a lot!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Option Explicit
Sub ReplaceData()
 
Dim lastRw1, lastRw2, nxtRw, m
 
'Determine last row with data, Sheet1
  lastRw1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row 'Determine last row with data, Sheet2
  lastRw2 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row 'Loop through Sheet 2, Column A
 
     For nxtRw = 2 To lastRw2
 
'Search Sheet1 Column A for value from Sheet 2
        With Sheets(1).Range("A2:A" & lastRw1)
          Set m = .Find(Sheets(2).Range("A" & nxtRw), LookAt:=xlWhole) 'Copy Sheet2 row if match is found
 
            If Not m Is Nothing Then
              Sheets(2).Range("A" & nxtRw).EntireRow.Copy _
              Sheets(1).Range("A" & m.Row)
 
            End If
 
        End With
     Next
 
End Sub

[mercatog]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub ReplaceData()
Dim LastRw1 As Long, LastRw2 As Long, NxtRw As Long
Dim i As Integer
Dim m As Range
Dim Tb
 
LastRw1 = Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
 
With Worksheets(2)
    LastRw2 = .Range("A" & Rows.Count).End(xlUp).Row
    For NxtRw = 2 To LastRw2
        Tb = Split(.Range("A" & NxtRw), ",")
        For i = 0 To UBound(Tb)
            With Sheets(1).Range("A2:A" & LastRw1)
                Set m = .Find(Tb(i), LookAt:=xlWhole)
                If Not m Is Nothing Then
                    .Range("A" & NxtRw).EntireRow.Copy Sheets(1).Range("A" & m.Row)
                    Set m = Nothing
'Exit For 'éventuellement
                End If
            End With
        Next i
    Next NxtRw
End With
End Sub

[Manu3100]

Bonjour,
Tout abord un grand merci, votre amelioration m'a fait avancé d'un grand pas.

Néanmoins il a toujours un petit soucis que je n'avais peut être pas précisé.

Si dans la sheet1 il y a:

MDM-123,MDM-321

Et dans la sheet2:

MDM-321

Le code ne trouve pas la correspondance et donc ne copie/colle pas la ligne en question.

Est-ce possible de rajouter une loop qui demande au code de regarder chaque string a l'intérieur de chaque cellule dans la sheet1?

Au sinon c'est exactement ce que je recherche a faire!
Loop VBA.xlsm
Merci de votre aide!!

[Theze]

Bonjour,

Remplace la ligne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
Set m = .Find(Tb(i), LookAt:=xlWhole)

du code de mercatog par cette ligne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
Set m = .Find(Tb(I), LookAt:=xlPart)

Hervé.

[Manu3100]

Merci beaucoup Hervé!!!

Juste serait il possible de garder les tout les strings d'une seule cell dans la colonneA sheet1. Car avec cette ligne cela garde que la ou les strings de la sheet2.

Je veux dire par la:

Sheet1 colonneA:

MDM-123,MDM-321

Sheet2 colonneA:

MDM-321

Du coup mon ideal serait de garder: MDM-123,MDM-321 dans la sheet1 colonneA


Merci d'avance!

Manu

[Theze]

Bonjour,

Sans trop de tests, je verrai cela comme ça :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
 
Sub Test()
 
    Dim PlageFe1 As Range
    Dim PlageFe2 As Range
    Dim CelFe1 As Range
    Dim CelFe2 As Range
    Dim Tb
    Dim I As Integer
    Dim DerCol As Long
 
    With Worksheets(1)
 
        Set PlageFe1 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
 
    End With
 
    With Worksheets(2)
 
        Set PlageFe2 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
        DerCol = .Cells(1, Columns.Count).End(xlToLeft).Column
 
    End With
 
    For Each CelFe2 In PlageFe2
 
        Tb = Split(CelFe2.Value, ",")
 
        For I = 0 To UBound(Tb)
 
            Set CelFe1 = PlageFe1.Find(Tb(I), , xlValues, xlPart)
 
            If Not CelFe1 Is Nothing Then
 
                PlageFe1.Range(PlageFe1.Cells(CelFe1.Row, 2), PlageFe1.Cells(CelFe1.Row, DerCol)).Value = _
                PlageFe2.Range(PlageFe2.Cells(CelFe2.Row, 2), PlageFe2.Cells(CelFe2.Row, DerCol)).Value
 
                Set CelFe1 = Nothing
 
            End If
 
        Next I
 
    Next CelFe2
 
End Sub

Hervé.