XL 2010 Renvoyer le N° de ligne d'une partie numérique identique à un code

ADOL · 16 Juin 2023

Bonjour/Bonsoir à Vous toutes et tous.
J'ai beaucoup essayé et beaucoup recherché mais en vain, et me voilà je me dirige vers vous pour m'aider à trouver mon besoin.
J'ai un fichier excel qui compte actuellement plus de 8600 lignes, sur lequel j'utilise une formule matricielle quavec laquelle le fichier
est devenu très très lent, lourd, fatigant et ennuyeux

De ce fait, je viens vers demander votre m’aide d'avoir une "Macro" qui compare, au moment de la saisie sur la feuil.1, une partie numérique
d’un code saisi, avec des codes existant dans l’autre feuille (Feuil.2) et renvoie automatiquement sur la même feuil.2 dans la case correspondant
de la colonne D, Le N° de la ligne du code similaire saisi sur la feuil.1.

Avec le fichier exempl, il y’a une Macro qui fait la même fonction souhaitée, mais il doit être adapté par les connaisseurs pour correspondre
le fichier exempl selon sa mise en forme actuelle, qui est identique au fichier principal.

Tous les détails nécessaires sont fournis avec le fichier ci-joint et j'espère avoir été bien claire ds mes détails

Je vous remercie beaucoup, par avance, pour le temps que vous avez voulu prendre pour mon aide.

ADOL · 16 Juin 2023

vgendron à dit:

Exact: erreur lorsque le code n'existe pas dans la feuille 1

voici le code commenté et corrigé

VB:

Sub ChercheCode2()

Dim Tab1() As Variant 'déclaration tablo vba
Dim Tab2() As Variant
Offset = 6 'pour compenser le démarrage du tableau à la ligne 7

With Sheets("Feuil1") 'avec la feuille1
    LastLine = .Range("C" & .Rows.Count).End(xlUp).Row 'dernière ligne NON vide de la colonne C
    Tab1 = .Range("G7:G" & LastLine).Value 'on met la colonne G dans le tablo
End With

With Sheets("Feuil2") 'avec la feuille2
    LastLine = .Range("E" & .Rows.Count).End(xlUp).Row 'dernière ligne NON vide de la colonne E
    Tab2 = .Range("D9:E" & LastLine).Value 'on met les colonne D et E dans le tablo
End With

Set dico1 = CreateObject("Scripting.Dictionary") 'création d'un dictionaire

For i = LBound(Tab1, 1) To UBound(Tab1, 1) 'pour chaque ligne du tablo
    clé = Split(Tab1(i, 1), " ")(1) 'on récupère la partie numérique pour en faire la clé
    If Not dico1.exists(clé) Then 'si la clé n'existe pas
        dico1.Add clé, i 'on ajoute la clé avec son indice
    End If
Next i

For i = LBound(Tab2, 1) To UBound(Tab2, 1) 'pour chaque ligne
    If dico1.exists(CStr(Tab2(i, 2))) Then 'si la clé existe
        Tab2(i, 1) = dico1(CStr(Tab2(i, 2))) + Offset 'on met sa valeur (indice) + offset
    End If
Next i

Sheets("Feuil2").Range("D9:E" & LastLine).Value = Tab2 'on copie le résultat dans la feuille
End Sub

Un grand merci vgendron ..... c'est parfait .... ça fonctionne très bien comme il faut.
Merci beaucoup pour ton aimable aide
Bonne continuation sur le forum

ADOL · 16 Juin 2023

Dranreb à dit:
De par sa conception, ma fonction ne devrait pas avoir cet inconvénient.

je vais l'essayer sur le fichier principal et je te dirai par la suite le résultat si c'est bon ou bien lent.

ADOL · 16 Juin 2023

vgendron à dit:

Exact: erreur lorsque le code n'existe pas dans la feuille 1

voici le code commenté et corrigé

VB:

Sub ChercheCode2()

Dim Tab1() As Variant 'déclaration tablo vba
Dim Tab2() As Variant
Offset = 6 'pour compenser le démarrage du tableau à la ligne 7

With Sheets("Feuil1") 'avec la feuille1
    LastLine = .Range("C" & .Rows.Count).End(xlUp).Row 'dernière ligne NON vide de la colonne C
    Tab1 = .Range("G7:G" & LastLine).Value 'on met la colonne G dans le tablo
End With

With Sheets("Feuil2") 'avec la feuille2
    LastLine = .Range("E" & .Rows.Count).End(xlUp).Row 'dernière ligne NON vide de la colonne E
    Tab2 = .Range("D9:E" & LastLine).Value 'on met les colonne D et E dans le tablo
End With

Set dico1 = CreateObject("Scripting.Dictionary") 'création d'un dictionaire

For i = LBound(Tab1, 1) To UBound(Tab1, 1) 'pour chaque ligne du tablo
    clé = Split(Tab1(i, 1), " ")(1) 'on récupère la partie numérique pour en faire la clé
    If Not dico1.exists(clé) Then 'si la clé n'existe pas
        dico1.Add clé, i 'on ajoute la clé avec son indice
    End If
Next i

For i = LBound(Tab2, 1) To UBound(Tab2, 1) 'pour chaque ligne
    If dico1.exists(CStr(Tab2(i, 2))) Then 'si la clé existe
        Tab2(i, 1) = dico1(CStr(Tab2(i, 2))) + Offset 'on met sa valeur (indice) + offset
    End If
Next i

Sheets("Feuil2").Range("D9:E" & LastLine).Value = Tab2 'on copie le résultat dans la feuille
End Sub

Re vgendron
Je reviens une une autre fois pour te dire:
Quand j'ai mis le code sur le fichier principal, l'erreur.9 vient de s'afficher de nouveau.
J'ai oublié de te précisé que la colonne G de la feuil.1 peut avoir des lignes vides et peut avoir des écritures texte sans numérique ou aussi des mentions avec des dates.
Peut-être l'erreur se déclenche de cette cause, parce que sur le fichier exempl j'ai remarque quand je modifie une ligne en texte uniquement parfois l'erreur se déclenche

vgendron · 16 Juin 2023

ADOL à dit:
Re vgendron
Je reviens une une autre fois pour te dire:
Quand j'ai mis le code sur le fichier principal, l'erreur.9 vient de s'afficher de nouveau.
J'ai oublié de te précisé que la colonne G de la feuil.1 peut avoir des lignes vides et peut avoir des écritures texte sans numérique ou aussi des mentions avec des dates.
Peut-être l'erreur se déclenche de cette cause, parce que sur le fichier exempl j'ai remarque quand je modifie une ligne en texte uniquement parfois l'erreur se déclenche

ha bah oui... si tu ne dis pas tout..
peux tu poster un fichier avec tous les cas de figure qui peuvent se présenter
il va falloir ajouter des tests
si vide ou si pas de numérique==> on passe à la ligne suivante

ADOL · 16 Juin 2023

vgendron à dit:
ha bah oui... si tu ne dis pas tout..
peux tu poster un fichier avec tous les cas de figure qui peuvent se présenter
il va falloir ajouter des tests
si vide ou si pas de numérique==> on passe à la ligne suivante

Alors voici un fichier avec la plupart des écriture qui peuvent être mentionnées sur la colonne G y compris des lignes vides ou des écritures avec des caractères spéciaux.
Merci une autre fois

vgendron · 16 Juin 2023

voir ce code

VB:

Sub ChercheCode2()

Dim Tab1() As Variant 'déclaration tablo vba
Dim Tab2() As Variant
Offset = 6 'pour compenser le démarrage du tableau à la ligne 7

With Sheets("Feuil1") 'avec la feuille1
    LastLine = .Range("C" & .Rows.Count).End(xlUp).Row 'dernière ligne NON vide de la colonne C
    Tab1 = .Range("G7:G" & LastLine).Value 'on met la colonne G dans le tablo
End With

With Sheets("Feuil2") 'avec la feuille2
    LastLine = .Range("E" & .Rows.Count).End(xlUp).Row 'dernière ligne NON vide de la colonne E
    Tab2 = .Range("D9:E" & LastLine).Value 'on met les colonne D et E dans le tablo
End With

Set dico1 = CreateObject("Scripting.Dictionary") 'création d'un dictionaire

For i = LBound(Tab1, 1) To UBound(Tab1, 1) 'pour chaque ligne du tablo
    If Tab1(i, 1) <> "" And InStr(Tab1(i, 1), " ") <> 0 Then 'si NON vide ET contient un espace
        Clé = Split(Tab1(i, 1), " ")(1) 'on récupère la partie numérique pour en faire la clé
        If Clé <> "" And IsNumeric(Clé) Then 'si clé non vide et la partie numérique est JUSTE un nombre (pas de lettre)
            If Not dico1.exists(Clé) Then 'si la clé n'existe pas
                dico1.Add Clé, i 'on ajoute la clé avec son indice
            End If
        End If
    End If
Next i

For i = LBound(Tab2, 1) To UBound(Tab2, 1) 'pour chaque ligne
    If dico1.exists(CStr(Tab2(i, 2))) Then 'si la clé existe
        Tab2(i, 1) = dico1(CStr(Tab2(i, 2))) + Offset 'on met sa valeur (indice) + offset
    End If
Next i

Sheets("Feuil2").Range("D9:E" & LastLine).Value = Tab2 'on copie le résultat dans la feuille
End Sub

ADOL · 16 Juin 2023

vgendron à dit:

voir ce code

VB:

Sub ChercheCode2()

Dim Tab1() As Variant 'déclaration tablo vba
Dim Tab2() As Variant
Offset = 6 'pour compenser le démarrage du tableau à la ligne 7

With Sheets("Feuil1") 'avec la feuille1
    LastLine = .Range("C" & .Rows.Count).End(xlUp).Row 'dernière ligne NON vide de la colonne C
    Tab1 = .Range("G7:G" & LastLine).Value 'on met la colonne G dans le tablo
End With

With Sheets("Feuil2") 'avec la feuille2
    LastLine = .Range("E" & .Rows.Count).End(xlUp).Row 'dernière ligne NON vide de la colonne E
    Tab2 = .Range("D9:E" & LastLine).Value 'on met les colonne D et E dans le tablo
End With

Set dico1 = CreateObject("Scripting.Dictionary") 'création d'un dictionaire

For i = LBound(Tab1, 1) To UBound(Tab1, 1) 'pour chaque ligne du tablo
    If Tab1(i, 1) <> "" And InStr(Tab1(i, 1), " ") <> 0 Then 'si NON vide ET contient un espace
        Clé = Split(Tab1(i, 1), " ")(1) 'on récupère la partie numérique pour en faire la clé
        If Clé <> "" And IsNumeric(Clé) Then 'si clé non vide et la partie numérique est JUSTE un nombre (pas de lettre)
            If Not dico1.exists(Clé) Then 'si la clé n'existe pas
                dico1.Add Clé, i 'on ajoute la clé avec son indice
            End If
        End If
    End If
Next i

For i = LBound(Tab2, 1) To UBound(Tab2, 1) 'pour chaque ligne
    If dico1.exists(CStr(Tab2(i, 2))) Then 'si la clé existe
        Tab2(i, 1) = dico1(CStr(Tab2(i, 2))) + Offset 'on met sa valeur (indice) + offset
    End If
Next i

Sheets("Feuil2").Range("D9:E" & LastLine).Value = Tab2 'on copie le résultat dans la feuille
End Sub

re vgendron
BRAVO cette fois-ci c'est bien parfait et le code à renvoyé 8104 enregistrements en quelques millisecondes
juste une petite rectification > Les codes à 6 chiffres n'ont pas été reconnus et leurs cases sont restés vides!!
est-il possible de vérifier cet point Svp ?

vgendron · 16 Juin 2023

il n'y a aucun controle sur le nombre de chiffres 6 ou 7
donc; s'ils ne sont pas reconnus.; c'est qu'il y a autre chose...

ADOL · 16 Juin 2023

vgendron à dit:
il n'y a aucun controle sur le nombre de chiffres 6 ou 7
donc; s'ils ne sont pas reconnus.; c'est qu'il y a autre chose...

Voilà j'ai vérifié les cas, un par un, et j'ai détecté le problème parce qu'il y'a certains codes à 7 chiffres qui n'ont été reconnus aussi, et le problème c'est quand il y'a un double espace entre la partie alphabétique et la partie numérique de l'écriture dans la colonne G, dans ce cas-ci le code serait ignoré
Exemple:
CHCB 4567892 > avec 2 espacé est ignoré
CHCB 4567892 > est reconnu
Voilà le problème

vgendron · 16 Juin 2023

Comme on ne sait pas s'il y a 2 ou 3 ou plus d'espace... j'ai ajouté un code pour supprimer tous les espaces

VB:

Sub ChercheCode3()

Dim Tab1() As Variant 'déclaration tablo vba
Dim Tab2() As Variant
Offset = 6 'pour compenser le démarrage du tableau à la ligne 7

With Sheets("Feuil1") 'avec la feuille1
    LastLine = .Range("C" & .Rows.Count).End(xlUp).Row 'dernière ligne NON vide de la colonne C
    Tab1 = .Range("G7:G" & LastLine).Value 'on met la colonne G dans le tablo
End With

With Sheets("Feuil2") 'avec la feuille2
    LastLine = .Range("E" & .Rows.Count).End(xlUp).Row 'dernière ligne NON vide de la colonne E
    Tab2 = .Range("D9:E" & LastLine).Value 'on met les colonne D et E dans le tablo
End With

Set dico1 = CreateObject("Scripting.Dictionary") 'création d'un dictionaire

For i = LBound(Tab1, 1) To UBound(Tab1, 1) 'pour chaque ligne du tablo
    If Tab1(i, 1) <> "" And InStr(Tab1(i, 1), " ") <> 0 Then 'si NON vide ET contient un espace
            Clé = SupEspace(CStr(Tab1(i, 1))) 'on récupère la partie numérique pour en faire la clé        If Clé <> "" And IsNumeric(Clé) Then 'si clé non vide et la partie numérique est JUSTE un nombre (pas de lettre)
            If Not dico1.exists(Clé) Then 'si la clé n'existe pas
                dico1.Add Clé, i 'on ajoute la clé avec son indice
            End If
    End If
Next i

For i = LBound(Tab2, 1) To UBound(Tab2, 1) 'pour chaque ligne
    If dico1.exists(CStr(Tab2(i, 2))) Then 'si la clé existe
        Tab2(i, 1) = dico1(CStr(Tab2(i, 2))) + Offset 'on met sa valeur (indice) + offset
    End If
Next i

Sheets("Feuil2").Range("D9:E" & LastLine).Value = Tab2 'on copie le résultat dans la feuille
End Sub
Function SupEspace(ValInit As String) As String
tempo = ""
For i = 1 To Len(ValInit)
    Carac = Mid(ValInit, i, 1)
    If IsNumeric(Carac) Then
        tempo = tempo & Carac    
    End If
Next i
SupEspace = tempo
End Function

Oneida · 17 Juin 2023

ADOL à dit:
J'ai rien trouvé à tester dans le fichier.
je vois juste une feuil.3 vide !!!

Oneida · 17 Juin 2023

Bonjour,
La feuil3 est une feuille que j'avais utilisee pour des tests

vous avez ecrit dans votre demande:
au moment de la saisie sur la feuil.1, une partie numérique
d’un code saisi, avec des codes existant dans l’autre feuille (Feuil.2) et renvoie automatiquement sur la même feuil.2 dans la case correspondant
Donc pour tester, il faut faire ce que vous avez ecrit.
Il n'a jamais ete question de mettre a jour toute la colonne sans modification de quoi que ce soit

ADOL · 17 Juin 2023

vgendron à dit:

Comme on ne sait pas s'il y a 2 ou 3 ou plus d'espace... j'ai ajouté un code pour supprimer tous les espaces

VB:

Sub ChercheCode3()

Dim Tab1() As Variant 'déclaration tablo vba
Dim Tab2() As Variant
Offset = 6 'pour compenser le démarrage du tableau à la ligne 7

With Sheets("Feuil1") 'avec la feuille1
    LastLine = .Range("C" & .Rows.Count).End(xlUp).Row 'dernière ligne NON vide de la colonne C
    Tab1 = .Range("G7:G" & LastLine).Value 'on met la colonne G dans le tablo
End With

With Sheets("Feuil2") 'avec la feuille2
    LastLine = .Range("E" & .Rows.Count).End(xlUp).Row 'dernière ligne NON vide de la colonne E
    Tab2 = .Range("D9:E" & LastLine).Value 'on met les colonne D et E dans le tablo
End With

Set dico1 = CreateObject("Scripting.Dictionary") 'création d'un dictionaire

For i = LBound(Tab1, 1) To UBound(Tab1, 1) 'pour chaque ligne du tablo
    If Tab1(i, 1) <> "" And InStr(Tab1(i, 1), " ") <> 0 Then 'si NON vide ET contient un espace
            Clé = SupEspace(CStr(Tab1(i, 1))) 'on récupère la partie numérique pour en faire la clé        If Clé <> "" And IsNumeric(Clé) Then 'si clé non vide et la partie numérique est JUSTE un nombre (pas de lettre)
            If Not dico1.exists(Clé) Then 'si la clé n'existe pas
                dico1.Add Clé, i 'on ajoute la clé avec son indice
            End If
    End If
Next i

For i = LBound(Tab2, 1) To UBound(Tab2, 1) 'pour chaque ligne
    If dico1.exists(CStr(Tab2(i, 2))) Then 'si la clé existe
        Tab2(i, 1) = dico1(CStr(Tab2(i, 2))) + Offset 'on met sa valeur (indice) + offset
    End If
Next i

Sheets("Feuil2").Range("D9:E" & LastLine).Value = Tab2 'on copie le résultat dans la feuille
End Sub
Function SupEspace(ValInit As String) As String
tempo = ""
For i = 1 To Len(ValInit)
    Carac = Mid(ValInit, i, 1)
    If IsNumeric(Carac) Then
        tempo = tempo & Carac   
    End If
Next i
SupEspace = tempo
End Function

Bonjour vgendron
Cette fois-ci tout est impeccable.
Avec la fonction ajoutée, toutes les fautes de frappe qui peuvent éventuellement être survenues lors de la saisie seront surmontées par cette astuce de la fonction ajoutée.
Un connaisseur vraiment en la matière

Un grand MERCI, et je te souhaite bonne continuation sur le forum et un bon weekend.

Dranreb · 17 Juin 2023

Et ma fonction, l'avez vous testée ?

ADOL · 17 Juin 2023

Dranreb à dit:
Et ma fonction, l'avez vous testée ?

Bonjour Dranreb
Je suis en train de tester toutes les solutions proposées sur le fichier pour comparer le temps de réponse de chaque fonction parce que le fichier est volumineux et était très lent avec une matricielle et aussi avec une autre fonction avec une formule en cases.
je te dirai le résultat du test par la suite.
De toute façon je vous remercie tous pour vos différentes aides et solutions proposés

Mandela avait déjà dit: (Il ne peut y avoir de plus grand don que celui de donner son temps pour aider les autres sans rien attendre en retourr)

Bon weekend à vous toutes et tous

XL 2010 Renvoyer le N° de ligne d'une partie numérique identique à un code

XLDnaute Nouveau

Pièces jointes

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

Pièces jointes

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

Discussions similaires

Partager cette page

Statistiques des forums