VBA - 2 Tableaux trouver cellules commune à chaque tableau

Version imprimable

29/03/2020, 18h48
irung

VBA - 2 Tableaux trouver cellules commune à chaque tableau

Bonjour

Contexte:
Feuille(1) 2 colonnes (1 colonne string "O6:O177" et une colonne date "S6:S177").
Feuille(2) 1 colonne (string A5:A120) et 1 ligne (date "B4:EG4")

VBA
Je teste feuille(1).Colonne("O6:O177") feuille(2).colonne("A5:A120")
if cellule commune trouvée alors je teste
feuille(1).colonne("S6:S177") avec feuille(2).ligne("B4:EG4")
if cellule commune trouvée alors (là je bloque totalement) je me place sur l'intersection de la feuille(2) (colonne(A) et Ligne(B:EG)

Merci de vos retours

Bonjour,

Essayez ceci

Code:

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 recherche()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim v As Object, d As Object
    Application.ScreenUpdating = False
    Set f1 = Sheets("feuil1")
    Set f2 = Sheets("feuil2")
 
    For i = 6 To 177
        Val_f1 = f1.Cells(i, "O")
        Date_f1 = f1.Cells(i, "S")
 
        With f2.Range("A5:A120")
            Set v = .Find(Val_f1, LookIn:=xlValues, lookat:=xlWhole)
            If Not v Is Nothing Then
                Pos1 = v.Address
                Do
                    Set d = f2.Range("B4:EG4").Find(Date_f1, LookIn:=xlFormulas, lookat:=xlWhole)
                    If Not d Is Nothing Then
                        f2.Select
                        Cells(v.Row, d.Column).Select
                        Exit Sub
                    End If
                    Set v = .FindNext(v)
                Loop While v <> "" And v.Address <> Pos1
            End If
        End With
    Next i
    Set v = Nothing
    Set d = Nothing
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Cdlt

30/03/2020, 09h30
irung

2 Tableaux trouver cellules commune à chaque tableau

Bonjour Arturo83,

Merci pour cette réponse rapide et efficace, cependant j'ai une

Citation:

erreur d'exécution 91 Variable objet ou variable de bloc with non définie

L'erreur ce produit à cette ligne

Code:

Loop While v <> "" And v.Address <> Pos1

Merci

Essayez avec celui_ci

Code:

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
Option Explicit
 
Sub recherche()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim v As Object, d As Object
    Dim i As Long
    Dim Val_f1 As String, Pos1 As String
    Dim Date_f1 As Date
 
    Set f1 = Sheets("Feuil1")
    Set f2 = Sheets("Feuil2")
    For i = 6 To 177
       Val_f1 = f1.Cells(i, "O")
       Date_f1 = f1.Cells(i, "S")
 
       With f2.Range("A5:A120")
           Set v = .Find(Val_f1, LookIn:=xlValues, lookat:=xlWhole)
           If Not v Is Nothing Then
               Pos1 = v.Address
               Do
                   Set d = f2.Range("B4:EG4").Find(Date_f1, LookIn:=xlFormulas, lookat:=xlWhole)
                   If Not d Is Nothing Then
                       f2.Select
                       Cells(v.Row, d.Column).Select
                       Exit Sub
                   End If
                   Set v = .FindNext(v)
               Loop While v Is Nothing And v.Address <> Pos1
           End If
       End With
    Next i
    Set v = Nothing
    Set d = Nothing
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

30/03/2020, 10h38
irung

Bonjour Arturo83

J'avais déjà intégré...
30/03/2020, 10h43
ARTURO83

et alors, ça marche ou pas?
30/03/2020, 11h15
irung

Non cela ne fonctionne pas tjrs la même erreur
30/03/2020, 11h23
ARTURO83

Bizarre, voici le fichier test, le problème est-il toujours là? sinon votre fichier est-il construit différemment?

Pièce jointe 550712

Cdlt

Code:

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
Option Explicit
Sub Worksheet_Change(ByVal Target As Range)
'On Error GoTo Erreur
Dim i, d, v, Val_f1, Date_f1, Pos1
Dim f1 As Worksheet, f2 As Worksheet

Application.ScreenUpdating = False

'Déclaration des variables
Set f1 = Sheets("Plan d'Actions")
Set f2 = Sheets("Planning")

'Sélection de la cellule intersect
If Not Intersect(Target, Range("$R6:$R177")) Is Nothing Then
For i = 6 To 177
        Val_f1 = f1.Cells(i, "O")
        Date_f1 = f1.Cells(i, "S")
 
        With f2.Range("A5:A120")
            Set v = .Find(Val_f1, LookIn:=xlValues, lookat:=xlWhole)
                If Not v Is Nothing Then
                    Pos1 = v.Address
                    Do
                      Set d = f2.Range("B4:EG4").Find(Date_f1, LookIn:=xlFormulas, lookat:=xlWhole)
                        If Not d Is Nothing Then
                            f2.Select
                            Cells(v.Row, d.Column).Select
                            Selection = v.Offset(0, 3) & " " & Format(v.Offset(0, 6), "hh:mm")
                            Exit Sub
                        End If
                        Set v = .FindNext(v)
                    Loop While v <> "" And v.Address <> Pos1
            End If
        End With
    Next i
End If
        

'Erreur:
Application.ScreenUpdating = True
Set v = Nothing
Set d = Nothing
Set f1 = Nothing
Set f2 = Nothing
End Sub

Je vous ai mis en gras ce que j'ai rajouté

Vous ne dites pas tout dès le début, je vous ai fourni un code qui fonctionne d'après ce que vous avez demandé. mais qui n'est pas tout à fait ce que vous voulez réellement.
Là je m'aperçois qu'en fait, il faut une macro évènementielle qui doit réagir à la saisie d'une valeur dans la colonne R,.
De plus, vous voulez copier dans la cellule trouvée dans "Planning", les valeurs concaténées des colonnes 3 et 6 de la feuille "Plan d'actions", dans ce cas il faut aussi relever les valeurs de la colonne 3 et 6 de la ligne sélectionnée. Est-ce bien cela?

Ca donnerait ceci:

Code:

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
Option Explicit
Dim i, d, v, Val_f1, Date_f1, Pos1
Dim f1 As Worksheet, f2 As Worksheet
Dim Val_Col3, Val_Col6
 
Sub Worksheet_Change(ByVal Target As Range)
 
    Application.ScreenUpdating = False
 
    'Déclaration des variables
    Set f1 = Sheets("Plan d'Actions")
    Set f2 = Sheets("Planning")
 
    'Sélection de la cellule intersect
    If Not Intersect(Target, Range("$R6:$R177")) Is Nothing Then
        Val_f1 = f1.Cells(Target.Row, "O")
        Date_f1 = f1.Cells(Target.Row, "S")
        Val_Col3 = f1.Cells(Target.Row, "C")
        Val_Col6 = f1.Cells(Target.Row, "F")
        Recherche
    End If
 
    Set v = Nothing
    Set d = Nothing
    Set f1 = Nothing
    Set f2 = Nothing
End Sub
 
Sub Recherche()
    f2.Select
    With f2.Range("A5:A120")
        Set v = .Find(Val_f1, LookIn:=xlValues, lookat:=xlWhole)
        If Not v Is Nothing Then
            Pos1 = v.Address
            Do
                Set d = f2.Range("B4:EG4").Find(Date_f1, LookIn:=xlFormulas, lookat:=xlWhole)
                If Not d Is Nothing Then
                    f2.Cells(v.Row, d.Column) = Val_Col3 & " " & Format(Val_Col6, "hh:mm")
                    Exit Sub
                End If
                Set v = .FindNext(v)
            Loop While v <> "" And v.Address <> Pos1
        End If
    End With
End Sub

Cdlt

30/03/2020, 13h02
irung

Désolé je ne voulais pas trop solliciter le forum et essayer de me débrouiller:(
Oui vous avez bien compris mon objectif
30/03/2020, 18h19
ARTURO83

Citation:

Pouvez-vous m'aider?

Oui bien sûr, mais le fichier en exemple que j'ai déposé fonctionne bien, peut-être que le votre à une structure différente, si c'est le cas il faut adapter.
Pouvez-vous déposer ici votre fichier sans les données confidentielles, juste ce qui est nécessaire pour faire les tests?
30/03/2020, 19h39
irung

1 pièce(s) jointe(s)

Je vous ai mis mon fichier "edulcoré" en exemple. Merci
30/03/2020, 20h28
ARTURO83

Essayez ceci
Pièce jointe 550952

Cdlt
31/03/2020, 00h05
irung

1 pièce(s) jointe(s)

Merci beaucoup. C'est ça super.
Par contre lorsque je rempli ma cellule O j'ai une erreur 91 qui apparait
Pièce jointe 551034

Merci
31/03/2020, 03h32
ARTURO83

Bonjour,

Remplacez la ligne par celle-ci:

Code:

Loop While Not v Is Nothing And v.Address <> Pos1

Cdlt
31/03/2020, 07h58
irung

Bonjour Arturo83

Je viens d'essayer avec

Code:

Loop While Not v Is Nothing And v.Address <> Pos1

:(

Et toujours même erreur 91
31/03/2020, 09h01
ARTURO83

Bonjour,

En fait l'erreur se produit si vous sélectionnez une valeur dans la colonne "R" alors que la colonne "S"(une date) est vide, ce qui génère une erreur. pour y remédier il faut aussi s'assurer qu'il y ait bien une date en "S".
donc la ligne incriminée et corrigée est:

Code:

If Not Intersect(Target, Range("$R6:$R177")) Is Nothing And Cells(Target.Row, "S") <> "" Then

le fichier
Pièce jointe 551110

Cdlt
31/03/2020, 09h41
irung
Quand j’exécute pas a pas la macro et qu'il arrive ici
Code:

1 2 With f2.Range("A5:A120") Set v = .Find(Val_f1, LookIn:=xlValues, lookat:=xlWhole)
Tout va bien

Dès que j'arrive sur

Code:

Loop While Not v Is Nothing And v.Address <> Pos1

De nouveau la même erreur 91.

Autre question subsidiaire plus pour ma culture, pourquoi la ligne f2.b4:ge4 est elle touchée
31/03/2020, 10h19
ARTURO83

Pour que je puisse reproduire le problème, dites-moi sur quelle cellule agissez-vous?

Citation:

Autre question subsidiaire plus pour ma culture, pkoi la ligne f2.b4:ge4 est elle touchée

pour 2 raisons:
-la première, c'est que vos dates sont issues de formules et excel ne me les trouvaient pas, j'ai donc dans un premier temps figer les valeurs des dates
-la deuxième, je transforme la date en numéro de série pour la recherche, ce qui évite d'avoir une inversion du mois avec le jour, exemple: 1/12/2020 et le 12/10/2020, en passant par le N° de série il n'y a plus de confusion possible.
-Enfin, à la fin de la recherche, tout est remis au bon format avec restitution des formules pour les calculs des dates.
31/03/2020, 11h11
irung

J'agis sur les cellules

f1.R6:R177
f1.S6:S177
f1.U6:U177

Merci pour votre abnégation et patience
31/03/2020, 12h13
ARTURO83

Ce n'est pas tout à fait ce que j'ai demandé, sachant que c'est la sélection d'un cellule de la colonne "R" qui déclenche la macro, je voulais connaître quelle cellule de la colonne "R3 vous avez sélectionné, car si je sélectionne la cellule S6, après avoir saisie une date en R6 et un commentaire en U6, la macro va tenter de rechercher l'action "Publication de la note d'information " dans la colonne A de la feuille "Planning", or celle-ci n'existe pas, mais ceci ne déclenche pas d'erreur. Quelle cellule de la colonne "R" avez-vous sélectionné et qui provoque l'erreur?
31/03/2020, 12h55
irung

R10 est renseignée, je veux modifié cette cellule à ce moment là l'erreur apparait

Chez moi je n'arrive pas à reproduire l'erreur, par contre on peut modifier la macro "recherche", les dates étant uniques dans "Planning" on peut écrire:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub Recherche()
    f2.Select
    f2.Rows(4).NumberFormat = "General"
    f2.Rows(4).Copy
    f2.Rows(4).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
    With f2.Range("A5:A120")
        Set v = .Find(Val_f1, LookIn:=xlValues, lookat:=xlWhole)
        If Not v Is Nothing Then
            Pos1 = v.Address
            Set d = f2.Range("B4:EG4").Find(Date_f1, LookIn:=xlFormulas, lookat:=xlWhole)
            If Not d Is Nothing Then f2.Cells(v.Row, d.Column) = Val_Col3 & " " & Format(Val_Col6, "hh:mm")
        End If
    End With
    f2.Range("B4").FormulaR1C1 = "=EDATE(R1C3,-6)"
    f2.Range("C4:EG4").FormulaR1C1 = "=RC[-1]+1"
    f2.Rows(4).NumberFormat = "[$-F800]dddd, mmmm dd, yyyy"
End Sub

Le fichier
Pièce jointe 551207

Cdlt

31/03/2020, 15h01
irung

Merci mille fois c'est super tout fonctionne à merveille