Msgbox avec tous résultats de recherche si valeur pas trouvé [Résolu/Fermé]

Signaler
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020
-
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020
-
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?



3 réponses

Messages postés
15406
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
6 novembre 2020
1 391
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 ?
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020
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!!
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020
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!
Messages postés
15406
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
6 novembre 2020
1 391 >
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020

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é()
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020
1 >
Messages postés
15406
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
6 novembre 2020

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


Messages postés
15406
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
6 novembre 2020
1 391 >
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020

Re,
Merci pour tous
Messages postés
12945
Date d'inscription
lundi 9 juin 2008
Statut
Contributeur
Dernière intervention
6 novembre 2020
720
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.
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020
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!
Messages postés
16285
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
3 novembre 2020
3 063
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
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020
1 >
Messages postés
15406
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
6 novembre 2020

Un gros merci pour votre aide!!
Messages postés
15406
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
6 novembre 2020
1 391 >
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020

Re,

Au plus simple:

Sub Recherche_Classeur_Ferme()
    Dim Cn As Object
    Dim Rst As Object 'Comparaison des deux fichiers
    Dim Fichier2, texte_SQL As String
    Dim NomFeuille As String, TS As String, TSondage, Nb, NS
        '-----------------------------
        With Worksheets("feuil1")
            Sondage = .Cells(2, 1).Value
            '.Range("E3:E100000").ClearContents
        End With
        'Définit le classeur fermé servant de base de données
        Fichier2 = "M:\Entrepot\BDFS\0_Sondages_a_saisir_Geotec\" & "SONDAGE.xlsx"
        'Fichier2 = "D:\_Docs_Prog_Excel\ADODB_excel\Michel_M\sondage_test.xlsx" 'MAQUETTE
        'Nom de la feuille dans le classeur fermé
        Table = "SONDAGE" & "$"
        Plage = "B1:B100000"
        Champ = "NO_SONDAGE"
        '--- Connexion ---
        Set Cn = CreateObject("ADODB.connection")
        With Cn
            .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
        '-----------------
        '... la requête avec WHERE et LIKE
        texte_SQL = "SELECT " & Champ & " FROM [" & Table & "] WHERE " & Champ & " like '" & Sondage & "%';"
        Set Rst = CreateObject("ADODB.Recordset")
        Rst.Open texte_SQL, Cn, adOpenStatic
        'Ecriture dans la feuille de calcul
        If Not Rst.EOF Then
            With Worksheets("feuil1")
                .Cells(2, 1).CopyFromRecordset Rst
                'traitement nombre de numero trouve
                Nb = Application.CountIf(.Columns(1), Sondage & "*")        'nombre de num trouves
                If Nb > 1 Then
                    TS = "["
                    For NS = 2 To Nb + 2: TS = TS & .Cells(NS, 1) & " ¤ ": Next NS
                    TS = Left(TS, Len(TS) - 3) & "]"
                    T_NT = T_NT & vbNewLine & Sondage & " en " & Nb + 1 & " exemplaires " & vbNewLine & TS
                End If
            End With
        Else
            'Infos non trouvees
            T_NT = T_NT & vbNewLine & Sondage
        End If
        '--- Fermeture connexion ---
        Rst.Close
        Cn.Close
        Set Cn = Nothing
        Set Rs = Nothing
End Sub


et une autre facon de faire si x num trouves, en restant dans la partie adodb

        'Ecriture dans la feuille de calcul
        If Not Rst.EOF Then
            Worksheets("feuil1").Cells(2, 5).CopyFromRecordset Rst
            Rst.movefirst
            TSondage = Rst.GetRows
            Nb = UBound(TSondage, 2)
            If Nb > 0 Then
                TS = "["
                For NS = 0 To Nb: TS = TS & TSondage(0, NS) & " ¤ ": Next NS
                TS = Left(TS, Len(TS) - 3) & "]"
                T_NT = T_NT & vbNewLine & Sondage & " en " & Nb + 1 & " exemplaires " & vbNewLine & TS
            End If
        Else
            'Infos non trouvees
            T_NT = T_NT & vbNewLine & Sondage
        End If
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020
1 >
Messages postés
15406
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
6 novembre 2020

Re,

Merci beaucoup ça fonctionne bien!

Par contre, une petite erreur dans le premier code me dit qu'il y a 3 exemplaires alors qu'il y en affiche seulement 2.

J'ai utilisé votre deuxième code et tout fonctionne correctement.

Petite question, est-ce que ça aurais été possible de choisir entre les 2 valeurs laquelle je veux copier dans la cellule A2?

Merci beaucoup!
Messages postés
15406
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
6 novembre 2020
1 391 >
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020

Re,

Normal, enlever le +1 pour Nb+1 dans
T_NT = T_NT & vbNewLine & Sondage & " en " & Nb + 1 & " exemplaires " & vbNewLine & TS


Ce +1 n'est valable que pour le code adodb dans l'autre facon, mais comme je l'ai fait en premier, y a eu un copier/coller sans rectification
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020
1 >
Messages postés
15406
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
6 novembre 2020

Re,

Oui, effectivement!