Msgbox con todos los resultados de búsqueda si el valor no se encuentra
Resuelto
bassmart
Mensajes publicados
281
Fecha de registro
Estado
Miembro
Última intervención
-
bassmart Mensajes publicados 281 Fecha de registro Estado Miembro Última intervención -
bassmart Mensajes publicados 281 Fecha de registro Estado Miembro Última intervención -
Hola foro,
Tengo una macro con dentro una consulta SQL para buscar un valor en un archivo cerrado (gracias a Michel por eso) que funciona muy bien. Cuando el valor buscado no se encuentra, añadí un "msgbox" para avisar al usuario que no se encontró el valor.
El problema es que si proceso varios archivos a la vez, se muestra tras el procesamiento de cada archivo. Lo que me gustaría es que se muestre solo una vez al final de todo el procesamiento de todos los archivos. Aún mejor, podría generar una especie de informe o diario (tipo Word) con todos los archivos en los que el valor no se encontró.
He probado en distintos lugares de mi código, pero sin éxito.
Aquí está mi código que se encuentra en un módulo:
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: Windows / Chrome 55.0.2883.87
3 respuestas
-
Hola, Justamente, he seguido los episodios sobre la solicitud que hicieron y que al final, aun así, utilizan el código de Michel_M. De hecho, había creado un código en tu archivo con tu programación inicial y al final hago un
.CopyFromRecordset
en lugar de un bucle para encontrar el/los números correctos. una pequeña pregunta: ¿estás seguro de que solo hay una sola encuesta que corresponda al número puesto al principio en la celda, porque en tu archivo de ejemplo hay un caso en el que hay dos C12003-004-08 C12003-004-09 y en este caso !! C12096-004-12 C12096A-004-12 Varios archivos, ok, pero ¿cómo los buscas?-
Hola,
Buen punto, ¡no lo había pensado!!
Hice la prueba y efectivamente en los 2 casos tengo un problema. Si tengo C28209A en mi celda de búsqueda, me copia el valor C28209-005-12 y no C28209A-005-12.
La forma en que busco en el libro cerrado es con el valor que está escrito en la celda (A2) de mi archivo, que corresponde a C28209A.
¿Cómo hacer para corregir el problema? ¿Existe alguna forma de avisarnos cuando encuentra 2 valores que coinciden y escoger cuál queremos usar?
¿Sería una mejor opción usar.copyfromrecordset
?
¡Muchas gracias!! -
Hola de nuevo, Estoy resolviendo el problema para los números como C28209A; había un pequeño error en la transcripción del nombre del cuaderno que corresponde a NO_SONDAGE dentro del cuaderno, me truncaba el nombre al quitar la "A" final. ¡Ahora funciona bien para estos casos!
- Hola a todos,
un archivo con los dos métodos de búsqueda y visualización no resuelve el problema de los msgbox, pero esto es bastante fácil de resolver
En "mi código" uso una consulta SQL con un WHERE y LIKE
Volvemos a hacer la misma pregunta:
-¿Cómo seleccionan los archivos a procesar y con qué llaman a su subrutinaSub compter_dans_fermé()
- Para seleccionar los libros, los seleccioné con un UserForm.
La forma en que llamo a la subrutina, usoCall contar_dans_fermé
Aquí está mi macro completa: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 Mensajes publicados 23437 Fecha de registro Estado Colaborador Última intervención Embajador 1 588
hola, ¿dices que llamas varias veces count_in_closed(), y que quieres mostrar el mensaje después de la última llamada?
¿cómo se realizan las múltiples llamadas a count_in_closed()?
si quieres crear un informe, basta con escribir Msg en un archivo en lugar de hacer el MsgBox.-
Hola yg_be,
Sí, puedo llamar a compter_dans_fermé() varias veces, en caso de que quiera procesar más de un libro a la vez.
Este macro está colocado en un módulo que forma parte de una macro mucho más grande que abre los libros seleccionados, realiza la maquetación de cada libro y los guarda con un nombre nuevo.
Si selecciono 5 libros, realiza el procesamiento de los 5 libros uno por uno en un bucle.
¿Quieres decir que debo cambiar la líneaMsgBox Msg, vbExclamation, "Attention!!!"
?
¡Gracias!
-
-
Cuando el valor buscado no se encuentra, añadí un "msgbox" para advertir al usuario que el valor no fue encontrado.
TE AVISÉ QUE TE PROPUSE ESTE PUNTO EN MIS RESPUESTAS :-(((
TU i=1 ES RIDÍCULO --
Tengo una macro con dentro una consulta SQL para buscar un valor en un archivo no abierto (gracias a Michel en este asunto)
ME ARREPIENTO DE HABERTE AYUDADO
Michel-
Hola Michel,
Lo siento por haberte ofendido, ¡no era mi intención! Funcionaba muy bien cuando abro un solo archivo.
Pero cuando abro 5 archivos a la vez (los proceso uno por uno), si no encuentra ninguna de las valores buscadas me envía 5 mensajes al final de cada uno de los archivos.
Para el i=1, tienes razón que es ridículo! Supondré que no soy un pro de la programación en VBA; hago lo mejor que puedo para lograr el resultado deseado.
¡Otra vez, perdón por haberte ofendido!! -
-
-
Tú persistes y firmas
a continuación copia del post 19 que no has querido leer...
.....
pequeña modificación a aportar para señalizar un falloWith 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
'gestionnaire erreur
MsgBox "Référénce cherchée: " & Cells(2, "A") & " introuvable.", vbCritical, vbOKOnly
End Sub
I ly a d'ailleurs beaucoup simple mais.... -
-
