Msgbox avec tous résultats de recherche si valeur pas trouvé

Résolu
bassmart Messages postés 281 Date d'inscription   Statut Membre Dernière intervention   -  
bassmart Messages postés 281 Date d'inscription   Statut Membre Dernière intervention   -
Bonjour le forum,

J'ai une macro avec à l'intérieure une requète SQL pour rechercher une valeur dans un fichier non ouvert (merci à Michel sur ce coup) qui fonctionne très bien. Lorsque la valeur recherché n'est pas trouvé, j'ai ajouté un "msgbox" pour avertir l'utilisateur que la valeur n'a pas été trouvé.

Le problème est que si je traite plusieurs fichiers en même temps, il l'affiche après le traitement de chacun des fichiers. Ce que je voudrais, c'est qu'il l'affiche seulement une fois à la fin du traitement de tout les fichiers. Encore mieux, je sortirais un genre de rapport ou de journal(style Word) avec tout les fichiers où que la valeur n'a pas été trouvé.

J'ai essayé à différent endroit dans mon code, mais sans succès.

Voici mon code qui se trouve dans un module:
Option Explicit
'------------------------------------------------------------
Sub compter_dans_fermé()
Dim Source As Object, Requete As Object
Dim Prefix As String, Fichier2 As String, Table As String, texte_SQL As String
Dim i As Integer
Dim Msg As String

'initialisation
Msg = ""

'----------------------------------Initialisations
    Prefix = ActiveSheet.Cells(2, "A")
    If Prefix = "" Then
        MsgBox "cellule vide", vbCritical, vbOKOnly
        Exit Sub
    End If
    'Définit le classeur fermé servant de base de données
     Fichier2 = "M:\Entrepot\BDFS\0_Sondages_a_saisir_Geotec\" & "SONDAGE.xlsx"
    'Nom de la feuille dans le classeur fermé
    Table = "SONDAGE" & "$"
   ' colonne de recherche
    'Champ = "NO_SONDAGE"

'-----------------------------------connexion
    Set Source = CreateObject("ADODB.connection")
    With Source
            .Provider = "Microsoft.Jet.OLEDB.4.0"
            .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
             & Fichier2 & ";Extended Properties=""Excel 12.0;HDR=YES;"""
            .Open
        End With

'--------------------------requete
     Set Requete = CreateObject("ADODB.Recordset")

     texte_SQL = "SELECT NO_SONDAGE FROM [" & Table & "]"
     Set Requete = Source.Execute(texte_SQL)

'-------------------------restitution
     With Requete
        .MoveFirst
        Do While Not .EOF
            If .Fields(0) Like Prefix & "*" Then
                ActiveSheet.Cells(2, "A") = .Fields(0)
                i = 1
                Exit Do
            End If
            .MoveNext
        Loop
            If i = 0 Then
                Msg = Msg & "La valeur " & ActiveSheet.Cells(2, "A") & " n'as pas été trouvé dans la table «SONDAGE»" & Chr(10)
            End If
     End With        
     
'Affichage du msgbox
If Msg <> "" Then
MsgBox Msg, vbExclamation, "Attention!!!"
End If
     
End Sub


Pouvez-vous m'aider?



A voir également:

3 réponses

Réponse 1 / 3
f894009 Messages postés 17277 Date d'inscription   Statut Membre Dernière intervention   1 713
 
Bonjour,

Justement, j'ai suivi les episodes a propos de la demande que vous aviez faites et que vous avez a la fin quand meme utilise le code de Michel_M.
J'avais d'ailleur fait un code sur votre fichier avec votre programmation de depart et en fin je fais un
 .CopyFromRecordset
au lieu d'une boucle pour trouver le ou les bons numeros, petite question: etes-vous sure qu'il n'y a qu'un seul sondage correspondant au numero mis au depart dans la cellule, car dans votre fichier exemple y a au un cas ou il y en a deux
C12003-004-08
C12003-004-09

et dans ce cas !!
C12096-004-12
C12096A-004-12


Plusieurs fichiers, ok, mais comment les recherchez-vous ?
0
bassmart Messages postés 281 Date d'inscription   Statut Membre Dernière intervention   1
 
Bonjour,

Bon point, je n'y avais même pas pensé!!

J'ai fait le test et effectivement dans les 2 cas j'ai un problème! Si j'ai C28209A dans ma cellule de recherche, il me copie la valeur C28209-005-12 et non pas C28209A-005-12.

La façon que je recherche dans le classeur fermé, c'est avec la valeur qui est inscrite dans la cellule (A2) de mon fichier qui correspond à C28209A.

Comment faire pour corriger le problème? Est-ce qu'il y a un moyen de nous avertir qu'il a trouvé 2 valeurs correspondantes et de choisir laquelle on veut utiliser?

Est-ce que le 
.copyfromrecordset
serait une meilleur option?

Merci beaucoup!!
0
bassmart Messages postés 281 Date d'inscription   Statut Membre Dernière intervention   1
 
Rebonjour,

Je résolu le problème pour les numéro comme C28209A, il y avais une petite erreur dans la retranscription du nom du classeur qui correspond à NO_SONDAGE à l'intérieur du classeur, il me tronquait le nom en enlevant le "A" de la fin.

Maintenant, ça fonctionne bien pour c'est cas!
0
f894009 Messages postés 17277 Date d'inscription   Statut Membre Dernière intervention   1 713 > bassmart Messages postés 281 Date d'inscription   Statut Membre Dernière intervention  
 
Bonjour a tous,

un fichier avec les deux methodes de recherche et affichage, ne résout pas le probleme des msgbox, mais ceci est assez simple a resoudre
Dans "mon code" j'utilse une requete SQL avec un WHERE et LIKE

Nous reposons la meme question:
-Comment selectionnez-vous les fichiers a traiter et avec comment appelez-vous votre subroutine 
Sub compter_dans_fermé()
0
bassmart Messages postés 281 Date d'inscription   Statut Membre Dernière intervention   1 > f894009 Messages postés 17277 Date d'inscription   Statut Membre Dernière intervention  
 
Pour sélectionner les classeurs, je l'ai sélectionnent à l'aide d'un Userform.

La façon dont j'appel la subroutine, j'utilise 
Call compter_dans_fermé


Voici ma macro complète: 
Option Explicit

Private Sub CommandButton1_Click()
   
    Dim QuelFichier()
    Dim Chemin, Fichier, Nomclasseur, strSONDAGE, Cible, Sondage, Value As String
    Dim DerLig, Lig, Dercol, Dercol2, NewDercol, DerLigS, DerLigF As Long
    Dim Prof, Prof2 As String
    Dim i, x, N, ligne, col, C, V, a As Integer
    Dim TInfos, nomfichier
    Dim celluletrouve, celluletrouve2, MaPlage As Range
    Dim Cn As ADODB.Connection
    Dim Fichier2 As String
    Dim NomFeuille As String, texte_SQL As String
    Dim Rst As ADODB.Recordset
    
    ChDrive "m"
    'ChDir "M:\Temporaire\Martin D'Anjou\Travail nouveau formulaire\Test piézocône"
    ChDir "M:\Entrepot\BDFS\1_Données de forages et sondages\"
'On Error GoTo fin
    QuelFichier = Application.GetOpenFilename("Fichier excel(*.xls; *.xlsx),*.xls;*.xlsx", , , , True)
    If IsArray(QuelFichier) Then
        For i = LBound(QuelFichier, 1) To UBound(QuelFichier, 1)
            Workbooks.Open QuelFichier(i)
            '-------------------------------------------
            'Nom de fichier SANS extention en partant du chemin complet
            Nomclasseur = Left(Mid(QuelFichier(i), InStrRev(QuelFichier(i), "\") + 1), Len(Mid(QuelFichier(i), InStrRev(QuelFichier(i), "\") + 1)) - 4)
                       
            If Left(Nomclasseur, 1) <> "C" Then
                If InStr(Nomclasseur, "C") > 6 Then
                    Nomclasseur = Mid(Nomclasseur, InStr((Nomclasseur), "C"), Len(Nomclasseur))
                ElseIf Mid(Nomclasseur, 3, 2) = "cp" Or Mid(Nomclasseur, 3, 2) = "CP" Then
                    Nomclasseur = "C" & Left(Nomclasseur, 2) & Mid(Nomclasseur, 5, Len(Nomclasseur) - 4)
                ElseIf Left(Nomclasseur, 1) = "c" Then
                    Nomclasseur = "C" & Mid(Nomclasseur, 2, Len(Nomclasseur))
                Else
                    Nomclasseur = "C" & Nomclasseur
                End If
            End If
            '-------------------------------------------
            Application.ScreenUpdating = False
           
            
            'traitement de chacune des feuilles ici
            '---------------------------------------
            For x = 1 To Sheets.Count
                With Sheets(x)
                    .Unprotect                 
                
                    
                    'Trouver la valeur Depth dans la colonne A sinon on delete
                    '----------------------------------------------------------
                    Prof = "depth"
                    Set celluletrouve = Range("A1:D10").Find(Prof, lookat:=xlWhole)
                        If celluletrouve Is Nothing Then
                            Prof2 = "Profondeur"
                            Set celluletrouve2 = Range("A1:D10").Find(Prof2, lookat:=xlPart)
                                If celluletrouve2 Is Nothing Then
                                    MsgBox "Colonne DEPTH n'as pas été trouvé", vbCritical
                                    Cells(1, 1).Value = "PROF"
                                    Cells(1, 2).Value = "Qt"
                                    Cells(1, 3).Value = "Fs"
                                    Cells(1, 4).Value = "U"
                                Else
                                    ligne = celluletrouve2.Row
                                    col = celluletrouve2.Column
                                    Cells(ligne + 1, col).EntireRow.Delete
                                    Cells(ligne, col).Value = "PROF"
                                        If col > 1 Then Range(Cells(1, 1), Cells(1, col - 1)).EntireColumn.Delete
                                        If ligne > 1 Then Range(Cells(1, 1), Cells(ligne - 1, 1)).EntireRow.Delete
                                End If
                        Else
                            ligne = celluletrouve.Row
                            col = celluletrouve.Column
                            Cells(ligne + 1, col).EntireRow.Delete
                            Cells(ligne, col).Value = "PROF"
                                If col > 1 Then Range(Cells(1, 1), Cells(1, col - 1)).Columns.Delete
                                If ligne > 1 Then Range(Cells(1, 1), Cells(ligne - 1, 1)).EntireRow.Delete
                        End If
                        
                    'On enlève les ligne vides du fichier
                    '------------------------------------
                    Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete ' problème ici delete tout
                        
                    'Ajout de NO_SITE et NO_SONDAGE au bout du tableau + changement de nom
                    '-----------------------------------------------------------------------
                    Dercol = Cells(1, Cells.Columns.Count).End(xlToLeft).Column
                    .Cells(1, Dercol + 1).Value = "NO_SITE"
                    .Cells(1, Dercol + 2).Value = "NO_SONDAGE"
                    Application.CutCopyMode = False
                    Dercol2 = Cells(1, Cells.Columns.Count).End(xlToLeft).Column
                    Range(Cells(1, 1), Cells(1, Dercol2)).NumberFormat = "General"
                    nomfichier = Nomclasseur
                    For N = 2 To Dercol2
                        Select Case .Cells(1, N).Value
                            Case "Qt", "qt"
                                .Cells(1, N).Value = "QT"
                            Case "Pw", "U", "u"
                                .Cells(1, N).Value = "U2"
                            Case "Fs", "fs"
                                .Cells(1, N).Value = "FS"
                            Case "Temp"
                                .Cells(1, N).Value = "TEMP"
                            Case "NO_SITE"
                                .Cells(2, N).Value = "6.02.06.MT.02." & Mid(Nomclasseur, 2, 2) & "000"
                                .Cells(2, N).EntireColumn.AutoFit
                            Case "NO_SONDAGE"
                                .Cells(2, N).Value = Mid(Nomclasseur, 1, Len(Nomclasseur))
                                .Cells(1, N).EntireColumn.AutoFit
                                N = Dercol2
                            'Case "Qc"
                                '.Cells(1, N).Value = "QC"
                            Case Else
                                .Columns(N).Delete
                                '.Cells(1, N).EntireColumn.Delete
                                N = N - 1
                        End Select
                    Next N
                    .Columns(1).Insert
                    NewDercol = Cells(1, Cells.Columns.Count).End(xlToLeft).Column
                    For C = 3 To DerLig
                        .Range(Cells(C, NewDercol - 1), Cells(C, NewDercol)).Value = .Range(Cells(2, NewDercol - 1), Cells(2, NewDercol)).Value
                    Next C
                    .Columns(NewDercol).Cut Destination:=Columns(1)
                    
                    
                End With
            Next x
            
        ' Spécifie le chemin du fichier à comparer
        '-------------------------------------------
        strSONDAGE = "M:\Entrepot\BDFS\0_Sondages_a_saisir_Geotec\" & "SONDAGE.xlsx"
       
        ' Vérifier que les fichiers A et B se trouvent dans le répertoire
        '----------------------------------------------------------------
        If Dir(strSONDAGE) = "" Then
            MsgBox "Le fichier SONDAGE.xlsx est introuvables", vbCritical + vbOKOnly, "Problème de fichier..."
            Exit Sub
        End If
        
        'Comparaison des deux fichiers
        '-----------------------------
        Call compter_dans_fermé
            
        'Copier la valeur cherché sur toute la colonne
        '---------------------------------------------
        DerLig = Range("B" & Rows.Count).End(xlUp).Row
        Dercol = Cells(1, Cells.Columns.Count).End(xlToLeft).Column
        Cells(2, 1).Copy
        With Range(Cells(3, 1), Cells(DerLig, 1))
        .PasteSpecial xlPasteValues
        End With
        Cells(2, Dercol).Copy
        With Range(Cells(3, Dercol), Cells(DerLig, Dercol))
        .PasteSpecial xlPasteValues
        End With
        
        Chemin = CurDir & "\Transfert_Geotec\"
            If Dir(Chemin, vbDirectory) = "" Then
                MkDir "Transfert_Geotec"
                Fichier = Nomclasseur & "_Geotec" & ".csv"
            Else
            
                Chemin = CurDir & "\Transfert_Geotec\"
                Fichier = Nomclasseur & "_Geotec" & ".csv"
            End If
               
            With ActiveWorkbook
                Application.DisplayAlerts = False
                .SaveAs Filename:=Chemin & Fichier, FileFormat:=xlCSV, CreateBackup:=False, local:=True
                .Close
                Application.DisplayAlerts = True
            End With
            '-------------------------------------------
        Next i
    Else
        MsgBox "Annuler"
    End If
    
    UserForm1.Hide
    ThisWorkbook.Saved = True
    Application.ScreenUpdating = True
    UserForm2.Show
    Application.ScreenUpdating = True


End Sub
0
f894009 Messages postés 17277 Date d'inscription   Statut Membre Dernière intervention   1 713 > bassmart Messages postés 281 Date d'inscription   Statut Membre Dernière intervention  
 
Re,
Merci pour tous
0
Réponse 2 / 3
yg_be Messages postés 23541 Date d'inscription   Statut Contributeur Dernière intervention   Ambassadeur 1 584
 
bonjour, tu veux-dire que tu appelles plusieurs fois compter_dans_fermé(), et que tu veux afficher le message après le dernier appel?
comment se font les multiples appels à compter_dans_fermé()?
si tu veux créer un rapport, il suffit d'écrire Msg dans un fichier au lier de faire le MsgBox.
0
bassmart Messages postés 281 Date d'inscription   Statut Membre Dernière intervention   1
 
Bonjour yg_be,

Oui, je peut appeler plusieurs fois compter_dans_fermé(), dans le cas ou je veux traiter plus d'un classeur à la fois.

Cette macro est placé dans un module qui fait partie d'une macro beaucoup plus grosse qui ouvre les classeurs sélectionnés, qui effectue la mise en page de chacun des classeurs et qui les sauvegardent sous un nouveau nom.

Si je sélectionne exemple 5 classeurs, il fait le traitement des 5 classeurs un à la fois en boucle.

Est-ce que tu veux dire que je dois changer la ligne 
MsgBox Msg, vbExclamation, "Attention!!!"
?

Merci!
0
Réponse 3 / 3
michel_m Messages postés 16602 Date d'inscription   Statut Contributeur Dernière intervention   3 313
 
Lorsque la valeur recherché n'est pas trouvé, j'ai ajouté un "msgbox" pour avertir l'utilisateur que la valeur n'a pas été trouvé.

JE TE SIGNALE QUE JE T'AI PROPOSE CE POINT DANS MES REPONSES :-(((

TON i=1 EST RIDICULE --


J'ai une macro avec à l'intérieure une requète SQL pour rechercher une valeur dans un fichier non ouvert (merci à Michel sur ce coup)

JE REGRETTE DE T'AVOIR AIDE
 Michel
0
bassmart Messages postés 281 Date d'inscription   Statut Membre Dernière intervention   1
 
Bonjour Michel,

Désolé te t'avoir offusqué, ce n'était pas le but! Ça fonctionnait très bien lorsque j'ouvre un seul fichier.

Mais lorsque j'ouvre exemple 5 fichiers en même temps (je les traitent un à la fois),si il ne trouve pas aucune des valeurs recherché il m'envoi 5 messages à la fin de chacun des fichiers.

Pour le i=1, tu as raison que c'est ridicule! J'assume que je ne suis pas un pro de la programmation VBA, je fais de mon mieux pour arriver au résultats voulu.

Encore désolé de t'avoir froissé!!
0
michel_m Messages postés 16602 Date d'inscription   Statut Contributeur Dernière intervention   3 313 > bassmart Messages postés 281 Date d'inscription   Statut Membre Dernière intervention  
 
Pour le i=1, tu as raison que c'est ridicule! J'assume que je ne suis pas un pro de la programmation VBA, je fais de mon mieux pour arriver au résultats voulu.


Tu n'es surtout pas un pro de la lecture des solutions qu'on te propose
0
bassmart Messages postés 281 Date d'inscription   Statut Membre Dernière intervention   1 > michel_m Messages postés 16602 Date d'inscription   Statut Contributeur Dernière intervention  
 
T''as solution fonctionnais très bien Michel.

J'ai seulement essayé de modifier ton code un peu pour qu'il m'affiche seulement une fois le message après avoir traité tout mes fichiers, mais sans succès. J'aurais du mettre ta version originale du code dans ma question!

Sincèrement désolé!!
0
michel_m Messages postés 16602 Date d'inscription   Statut Contributeur Dernière intervention   3 313 > bassmart Messages postés 281 Date d'inscription   Statut Membre Dernière intervention  
 
Tu persistes et signes

ci dessous copie du post 19 que tu n'as pas dédaigné lire...

.....

peite modif à apporter pour signaler un échec 

With Requete
        .MoveFirst
        Do While Not .EOF
            test = .fields(0)
            If .fields(0) Like Prefix & "*" Then
                ActiveSheet.Cells(2, "A") = .fields(0)
Exit Sub
            End If
            .MoveNext
        Loop
     End With
'gestionnnaire erreur
MsgBox "Référénce cherchée: " & Cells(2, "A") & " introuvable.", vbCritical, vbOKOnly
End Sub


I ly a d'ailleurs beaucoup simple mais....
0
bassmart Messages postés 281 Date d'inscription   Statut Membre Dernière intervention   1 > michel_m Messages postés 16602 Date d'inscription   Statut Contributeur Dernière intervention  
 
Je ne persiste pas et signe Michel!

Ton code (que tu mentionne) fonctionne très bien, je l'ai essayé!

Mais bon, je ne peut changer ce qui a été fait! Je n'avais surtout pas l'intention de vexer personne ici sur le forum.

Encore désolé!
0

Discussions similaires

Trouver numéro snapchat
Rnby -
Pierrecastor -

1 réponse
Recherche de pairs sur utorrent bloqué
flo.h -
Claire -

4 réponses
additionner nombres dans cellules avec texte
kawimaki -
kawimaki -

6 réponses