Msgbox with all search results if value not found
Solved
bassmart
Posted messages
281
Registration date
Status
Member
Last intervention
-
bassmart Posted messages 281 Registration date Status Member Last intervention -
bassmart Posted messages 281 Registration date Status Member Last intervention -
Hello forum,
I have a macro that contains an SQL query to search for a value in a closed file (thanks to Michel for this) which works very well. When the searched value is not found, I added a "msgbox" to warn the user that the value was not found.
The problem is that if I process several files at the same time, it displays after the processing of each file. What I would like is that it only displays once at the end of processing all files. Even better, I would output a kind of report or log (Word-style) with all the files where the value was not found.
I have tried at different places in my code, but without success.
Here is my code which is in a module:
Pouvez-vous m'aider?
Configuration: Configuration: Windows / Chrome 55.0.2883.87
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?
Configuration: Configuration: Windows / Chrome 55.0.2883.87
3 answers
-
Hello, Actually, I followed the episodes about the request you made and that you still end up using Michel_M's code. I had, by the way, written a code on your file with your starting programming and in the end I do a
.CopyFromRecordset
instead of a loop to find the right number or numbers. quick question: are you sure there is only one survey corresponding to the number placed at the start in the cell, because in your example file there is one case where there are two C12003-004-08 C12003-004-09 and in this case!! C12096-004-12 C12096A-004-12 Multiple files, okay, but how do you search them?-
Hello, Good point, I hadn’t even thought of that!! I ran the test and indeed in both cases I have a problem! If I have C28209A in my search cell, it copies the value C28209-005-12 and not C28209A-005-12. The way I search in the closed workbook is with the value that is written in the cell (A2) of my file which corresponds to C28209A. How can I fix the problem? Is there a way to alert us that two matching values were found and choose which one we want to use? Would .copyfromrecordset be a better option? Thanks a lot!!
-
Hello again, I’m solving the issue for numbers like C28209A; there was a small error in transcription of the workbook name that corresponds to NO_SONDAGE inside the workbook, it was truncating the name by removing the trailing “A.” Now, it works well for these cases!
- Hello everyone, a file with the two search and display methods does not solve the problem of the msgbox, but this is quite simply solved. In "my code" I use an SQL query with a WHERE and LIKE. We ask the same question again: - How do you select the files to process and how do you call your subroutine Sub compter_dans_fermé()
- To select the workbooks, I select them using a UserForm.
The way I call the subroutine, I useCall compter_dans_fermé
Here is my complete macro: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
-
-
yg_be Posted messages 23437 Registration date Status Contributor Last intervention Ambassadeur 1 588
Hello, do you mean that you call compter_dans_fermé() several times, and you want to display the message after the last call?
how are multiple calls to compter_dans_fermé() handled?
if you want to create a report, you just need to write Msg to a file instead of using the MsgBox.-
Hello yg_be, Yes, I can call compter_dans_fermé() multiple times, in case I want to process more than one workbook at once. This macro is placed in a module that is part of a much larger macro that opens the selected workbooks, performs the layout for each workbook, and saves them under a new name. If I select, for example, 5 workbooks, it processes the 5 workbooks one by one in a loop. Do you mean that I should change the line MsgBox Msg, vbExclamation, "Attention!!!"? Thanks!
-
-
When the searched value is not found, I added a "msgbox" to warn the user that the value was not found.
I POINT OUT TO YOU THAT I PROPOSED THIS POINT IN MY ANSWERS :-(((
YOUR i=1 IS RIDICULOUS --
I have a macro with an SQL query inside to search for a value in a file that is not open (thanks to Michel for this)
I REGRET HAVING SAID I HELPED YOU
Michel-
Hello Michel, Sorry for offending you, that wasn’t the goal! It worked very well when I open a single file. But when I open 5 files at the same time (I process them one by one), if it doesn’t find any of the values searched for it sends me 5 messages at the end of each file. For i=1, you’re right that it’s ridiculous! I assume I’m not a VBA programming pro, I’m doing my best to achieve the desired result. Sorry again for upsetting you!!
-
-
-
You persist and sign
here below a copy of post 19 that you did not deign to read...
.....
a small modification to make to signal a failureWith 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.... -
-
