Fonction FIND avec plusieurs valeurs dans une meme cellule.

**Manu3100** · 02/07/2015, 11h52

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** · 02/07/2015, 12h11

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** · 02/07/2015, 19h16

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** · 02/07/2015, 19h22

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** · 02/07/2015, 19h43

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** · 03/07/2015, 07h15

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

**Manu3100** · 05/07/2015, 00h56

Merci Hervé de ta réponse, j'ai essayé le code ci dessus et en faite il remplace les strings de la colonnes A sheet2 et colle dans la colonneA sheet1.

Ce que j'essaye de faire c'est de tous les garder dans la colonne1.

Cas 1:
ex: ColonneA sheet2 cell10:
MDM-123,MDM345

ColonneA sheet1 cell20:
MDM-345

Resultat après la macro:ColonneA sheet1 cell20:
MDM-123,MDM-345

Cas2:
ColonneA sheet2 cell10:
MDM-345,MDM-789

ColonneA sheet1 cell20:
MDM-123,MDM-345

Resultat après la macro:ColonneA sheet1 cell20:
MDM-123,MDM-345,MDM-789

1) Jai réussi a régler ce problem a moitié car je ne comprend pas pourquoi. La macro copie les strings de la colonneA de la sheet1 et les colle sur la meme ligne de la sheet1

ex: ColonneA sheet2 cell10:
MDM-123,MDM345

ColonneA sheet1 cell10:
MDM-678

ColonneA sheet1 cell20:
MDM-345

Résultat après la macro:ColonneA sheet1 cell10:
MDM-678,MDM-123,MDM-345

Au lieu de ColonneA sheet1 cell20:
MDM-123,MDM-345

2) De plus j'ai essayé de rajouter une ligne ELSE de le code pour dire que si il n'y a pas de match alors copier la ligne entier de A:ZZ (par exemple) de la sheet2 à la dernière ligne disponible de la sheet1. Sans succès

Voici le code:

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
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
Sub ReplaceData2()
Dim LastRw1 As Long, LastRw2 As Long, NxtRw As Long
Dim I As Integer
Dim m As Range
Dim Tb
 
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
 
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(Trim(Tb(I)), LookAt:=xlPart)
 
                    If Not m Is Nothing Then
                    Sheets(1).Range("A" & m.Row) = Sheets(1).Range("A" & m.Row) & "," & Sheets(2).Range("A" & m.Row)
 
                    Sheets(2).Range("B" & NxtRw & ":Q" & NxtRw).Copy _
                    Sheets(1).Range("B" & m.Row)
 
                    Set m = Nothing
 
                End If
 
            End With
 
        Next I
 
    Next NxtRw
 
End With
 
 
'*****************************************
'Erase strings duplicates in each cell    *
'*****************************************
    Dim starval As String
    Dim finval As String
    Dim strarray() As String
    Dim x As Long
    Dim k As Long
    Dim cell As Range
    Dim rw As Long
 
' step through each cell in range
 
    For Each cell In Sheets(1).Range("A1:A50")
        Erase strarray ' erase array
        finval = "" ' erase final value"
        starval = cell.Value
        On Error Resume Next
 
        strarray = Split(starval, ",")
 
         'Step through length of string and look for duplicate
        For rw = 0 To UBound(strarray)
 
            For k = rw + 1 To UBound(strarray)
                If Trim(strarray(k)) = Trim(strarray(rw)) Then
                    strarray(k) = "" 'if duplicate clear array value
                End If
            Next k
        Next rw
 
         ' combine all value in string less duplicate
        For x = 0 To UBound(strarray)
            If strarray(x) <> "" Then
 
                finval = finval & Trim(strarray(x)) & ","
            End If
 
        Next x
         ' remove last space and comma
        finval = Trim(finval)
        finval = Left(finval, Len(finval) - 1)
         ' output value to Column J
        cell.Offset(0, 0).Value = finval
 
    Next cell
 
End Sub

Je suis preneur de toutes ameliorations et de commentaires. Car ce code je vais l'appliquer sur une gross base de donnée...

Merci encore pour vos conseilles!
Manu

**patricktoulon** · 05/07/2015, 13h01

bonjour

je n'ai pas lu tout en entier mais je crois comprendre que tu check les cellules A du sheets 2 dans le sheets (1)
si oui on copie la ligne sinon rien

2 parametre tu voudrais garde la cellule A du sheets(1) intacte
et bien tu reprend le code de mercatog en changeant dans la boucle la condition sur le nothing par ceci:

Code :

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

1
2
3

If Not m Is Nothing Then
                    .Range(cells( NxtRw,2),cells( NxtRw,columns.count)).Copy Sheets(1).Range("B" & m.Row)

ainsi tu garde la colonne A du sheets(1) intacte

en gardant bien eviement l'argument "xlpart" que t'a suggéré theze
cela donnerait ceci:

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:=xlPart)
                If Not m Is Nothing Then
                    .Range(cells( NxtRw,2),cells( NxtRw,columns.count)).Copy Sheets(1).Range("B" & m.Row)
                    Set m = Nothing
'Exit For 'éventuellement
                End If
            End With
        Next i
    Next NxtRw
End With
End Sub

Edit:!!!!!!!!!!!
et qoi que la ligne en rouge se trouve dans un (with/end with) appartenant au sheet(1) cela peut engendrer non pas un message d'erreur mais une action inutile (puisque copie de sheets(1) vers sheets(1))
donc devant tu met sheets(2)

**Manu3100** · 05/07/2015, 13h17

Bonjour,

Merci de ta réponse, mais cela me met Application defined or object defined error.

**patricktoulon** · 05/07/2015, 13h21

j'ai corrigé un petit detail qui justifie a mon avis ton message

**Manu3100** · 05/07/2015, 13h36

Ca ne marche toujours pas, des fois j'ai un message d'erreur le meme que tout a l'heure. Je continue a chercher de mon personnellement (j'y suis depuis vendredi soir..)

Je vais re expliquer mon but:

1)Je check les cellules A du sheets 2 dans le sheets (1) si oui on copie la ligne a partir de colonneB sheet2 a la sheet1. Et si dans la sheet2 il y a un ou plusieurs nouveaux string on update la cell en question dans la sheet1. Sachant que les strings correspondant ne sont pas sur les memes lignes, exemple:

ColonneA sheet2 cell10: MDM-123,MDM345

ColonneA sheet1 cell20: MDM-9999,MDM-5674,MDM-345

Au lieu de ColonneA sheet1 cell20:
MDM-9999,MDM-5674,MDM-345,MDM-123

2) Si il n'y a pas de match alors je copie la ligne entière de la sheet2 et colle a la dernière ligne de la sheet1. (pas encore fait, prochaine étape.)

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:=xlPart)
                If Not m Is Nothing Then
                    Sheets(2).Range(Cells(NxtRw, 2), Cells(NxtRw, Columns.Count)).Copy Sheets(1).Range("B" & m.Row)
                    Set m = Nothing
'Exit For 'éventuellement
                End If
            End With
        Next i
    Next NxtRw
End With
End Sub

**patricktoulon** · 05/07/2015, 14h07

wouh!!!
alors tu a un soucis car chez moi tes deux modules fonctionnent

dans le module2

cette ligne est inutile car en l'etat tes deux sheets on les meme valeurs

Code :

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

Sheets(1).Range("A" & m.Row) = Sheets(1).Range("A" & m.Row) & "," & Sheets(2).Range("A" & m.Row)

mais si ce n'etait pas le cas il faudrait ajouter seulement la partie manquante
j'ai donc repris ton modules 2
en tout cas les 2 modules chez moi fonction pour la copie
voila ton module 2

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
Sub MDMNumbers()
    Dim LastRw1 As Long, LastRw2 As Long, NxtRw As Long
    Dim i As Integer
    Dim m As Range
    Dim Tb
 
    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
    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(Trim(Tb(i)), LookAt:=xlPart)
 
                    If Not m Is Nothing Then
                        'on rajoute que les partie manquantes dans la colonne A du sheets(1)
                        For it = 0 To UBound(Tb)
                            If InStr(Sheets(1).Range("A" & m.Row), Tb(it)) < 0 Then Sheets(1).Range("A" & m.Row) = Sheets(1).Range("A" & m.Row) & "," & Tb(it)
                        Next
                        Sheets(2).Range("B" & NxtRw & ":Q" & NxtRw).Copy _
                                Sheets(1).Range("B" & m.Row)
                        Set m = Nothing
                        Exit For    ' ici on sort sinon l'operation se renouvelera a chaque occurence de tb(i)ce qui n'est pas necessaire puisque c'est fait en une seule fois par la 2 eme boucle for pour le tb
                    End If
                End With
            Next i
        Next NxtRw
    End With
End Sub

si ca ne fonctionne pas chez toi tu a un autre soucis

**Manu3100** · 05/07/2015, 14h46

Je ne fais que essayer sur mon ordi (un mac) donc cela doit venir de moi.
La ligne se copie parfaitement mais la colonne A ne s'update pas.

J'essayerai au travail demain et il ne me restera plus q'a coder quand il n'y a pas de match alors je copie la ligne entière de la sheet2 et colle a la dernière ligne de la sheet1

Merci énormément!!!

Donc ces 2 modules fonctionnes:

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
Sub MDMNumbers()
    Dim LastRw1 As Long, LastRw2 As Long, NxtRw As Long
    Dim i As Integer
    Dim m As Range
    Dim Tb
 
    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
    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(Trim(Tb(i)), LookAt:=xlPart)
 
                    If Not m Is Nothing Then
                        'on rajoute que les partie manquantes dans la colonne A du sheets(1)
                        For it = 0 To UBound(Tb)
                            If InStr(Sheets(1).Range("A" & m.Row), Tb(it)) < 0 Then Sheets(1).Range("A" & m.Row) = Sheets(1).Range("A" & m.Row) & "," & Tb(it)
                        Next
                        Sheets(2).Range("B" & NxtRw & ":Q" & NxtRw).Copy _
                                Sheets(1).Range("B" & m.Row)
                        Set m = Nothing
                        Exit For    ' ici on sort sinon l'operation se renouvelera a chaque occurence de tb(i)ce qui n'est pas necessaire puisque c'est fait en une seule fois par la 2 eme boucle for pour le tb
                    End If
                End With
            Next i
        Next NxtRw
    End With
End Sub

Et celui ci:

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:=xlPart)
                If Not m Is Nothing Then
                    Sheets(2).Range(cells( NxtRw,2),cells( NxtRw,columns.count)).Copy Sheets(1).Range("B" & m.Row)
                    Set m = Nothing
'Exit For 'éventuellement
                End If
            End With
        Next i
    Next NxtRw
End With
End Sub

**Manu3100** · 05/07/2015, 18h56

Merci à tout le monde!

Fonction FIND avec plusieurs valeurs dans une meme cellule. [Toutes versions]

Macros et VBA Excel

Discussions similaires

Partager

Partager