VBA - 2 Tableaux trouver cellules commune à chaque tableau

Version imprimable

Voir 40 message(s) de cette discussion en une page

29/03/2020, 17h48
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, 08h30
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, 09h38
irung

Bonjour Arturo83

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

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

Non cela ne fonctionne pas tjrs la même erreur
30/03/2020, 10h23
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, 12h02
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, 17h19
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, 18h39
irung

1 pièce(s) jointe(s)

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

Essayez ceci
Pièce jointe 550952

Cdlt
30/03/2020, 23h05
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, 02h32
ARTURO83

Bonjour,

Remplacez la ligne par celle-ci:

Code:

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

Cdlt
31/03/2020, 06h58
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, 08h01
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, 08h41
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, 09h19
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.

Voir 40 message(s) de cette discussion en une page