Vous utilisez un navigateur obsolète. Il se peut que ce site ou d'autres sites Web ne s'affichent pas correctement. Vous devez le mettre à jour ou utiliser un navigateur alternatif.
recherche d'une donnee dans fichiers fermes redemande merci
bonjour
n'ayant pas eu de réponses a ma derniere demande, je me permet de la reformuler avec un fichier exemple
il y a autant de fichiers que de clients
j'aimerais a l'aide d'une macro pouvoir faire une recherche a l'aide d'une inputbox sur la colone F d'une valeur (par exemple voiture), dans les fichiers fermés
le resultat peut etre dans une combobox ou msgbox avec la valeur demandée ansi que la valeur de la cellule C3 ( code client).
peut etre qu'avec l'exemple cela sera plus clair
Re : recherche d'une donnee dans fichiers fermes redemande merci
Bonjour,
Une piste avec le code suivant à copier dans un module standard
Code:
Sub RechercheDansClasseurs()
Dim FS As FileSearch
Dim WB As Workbook
Dim S As Worksheet
Dim R As Range
Dim Recherche
Dim var
Dim i&
Dim k&
Dim cpt&
Dim A$
Dim T()
Recherche = Application.InputBox( _
prompt:="Tapez le mot recherché.", _
Title:="Recherche dans les classeurs des clients", _
Type:=2)
If Recherche = False Then Exit Sub
Set FS = Application.FileSearch
FS.NewSearch
FS.LookIn = ThisWorkbook.Path
FS.FileType = msoFileTypeExcelWorkbooks
If FS.Execute() = 0 Then Exit Sub
'--- Si classeur déjà ouvert, on sort ---
On Error Resume Next
For i& = 1 To FS.FoundFiles.Count
If FS.FoundFiles(i&) <> ThisWorkbook.FullName Then
Err.Clear
A$ = Mid(FS.FoundFiles(i&), InStrRev(FS.FoundFiles(i&), "\") + 1)
Set WB = Workbooks(A$)
If Err = 0 Then
MsgBox "Le classeur ''" & A$ & "'' est ouvert. Veuillez le fermer."
Exit Sub
End If
End If
Next i&
On Error GoTo 0
'--- Recherche dans les classeurs ---
Application.ScreenUpdating = False
For i& = 1 To FS.FoundFiles.Count
If FS.FoundFiles(i&) <> ThisWorkbook.FullName Then
Set WB = GetObject(FS.FoundFiles(i&))
Set S = WB.Sheets(1)
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[f65536].End(xlUp).Row, 7))
var = R
For k& = 1 To UBound(var, 1)
If Trim(LCase(var(k&, 6))) = Trim(LCase(Recherche)) Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 3, 1 To cpt&)
T(1, cpt&) = WB.Name
T(2, cpt&) = var(3, 3)
T(3, cpt&) = Recherche
End If
Next k&
WB.Close False
Set WB = Nothing
End If
Next i&
Set FS = Nothing
If cpt& = 0 Then
MsgBox "Aucune occurence du mot ''" & Recherche & "'' n'a été trouvé."
Application.ScreenUpdating = True
Exit Sub
End If
'--- Inscription du résultat dans une nouvelle feuille ---
Set WB = ThisWorkbook
Set S = WB.Sheets.Add(after:=WB.Sheets(WB.Sheets.Count))
Set R = S.Range(S.Cells(2, 1), S.Cells(UBound(T, 2) + 1, UBound(T, 1)))
R = Application.Transpose(T)
Set R = S.Range("a1:c1")
R = Array("CLASSEUR", "CLIENT", "MOT RECHERCHE")
R.Font.Bold = True
R.HorizontalAlignment = xlCenter
R.Interior.ColorIndex = 35
S.Cells.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
RESTRICTION
Les classeurs clients doivent être dans le même dossier que le classeur contenant cette macro
et AUCUN autre classeur n'étant pas un classeur clients ne doit s'y trouver.
FONCTIONNEMENT
1) téléchargez l'exemple en pièce jointe pour plus de facilité
2) ouvrez le classeur "Programme" et lancez la macro "RechercheDansClasseurs"
3) renseignez l'InputBox du mot recherché
4) le programme ouvre tous les classeurs et y cherche le mot sélectionné puis affiche le résultat dans une nouvelle feuille
Une piste avec le code suivant à copier dans un module standard
Code:
Sub RechercheDansClasseurs()
Dim FS As FileSearch
Dim WB As Workbook
Dim S As Worksheet
Dim R As Range
Dim Recherche
Dim var
Dim i&
Dim k&
Dim cpt&
Dim A$
Dim T()
Recherche = Application.InputBox( _
prompt:="Tapez le mot recherché.", _
Title:="Recherche dans les classeurs des clients", _
Type:=2)
If Recherche = False Then Exit Sub
Set FS = Application.FileSearch
FS.NewSearch
FS.LookIn = ThisWorkbook.Path
FS.FileType = msoFileTypeExcelWorkbooks
If FS.Execute() = 0 Then Exit Sub
'--- Si classeur déjà ouvert, on sort ---
On Error Resume Next
For i& = 1 To FS.FoundFiles.Count
If FS.FoundFiles(i&) <> ThisWorkbook.FullName Then
Err.Clear
A$ = Mid(FS.FoundFiles(i&), InStrRev(FS.FoundFiles(i&), "\") + 1)
Set WB = Workbooks(A$)
If Err = 0 Then
MsgBox "Le classeur ''" & A$ & "'' est ouvert. Veuillez le fermer."
Exit Sub
End If
End If
Next i&
On Error GoTo 0
'--- Recherche dans les classeurs ---
Application.ScreenUpdating = False
For i& = 1 To FS.FoundFiles.Count
If FS.FoundFiles(i&) <> ThisWorkbook.FullName Then
Set WB = GetObject(FS.FoundFiles(i&))
Set S = WB.Sheets(1)
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[f65536].End(xlUp).Row, 7))
var = R
For k& = 1 To UBound(var, 1)
If Trim(LCase(var(k&, 6))) = Trim(LCase(Recherche)) Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 3, 1 To cpt&)
T(1, cpt&) = WB.Name
T(2, cpt&) = var(3, 3)
T(3, cpt&) = Recherche
End If
Next k&
WB.Close False
Set WB = Nothing
End If
Next i&
Set FS = Nothing
If cpt& = 0 Then
MsgBox "Aucune occurence du mot ''" & Recherche & "'' n'a été trouvé."
Application.ScreenUpdating = True
Exit Sub
End If
'--- Inscription du résultat dans une nouvelle feuille ---
Set WB = ThisWorkbook
Set S = WB.Sheets.Add(after:=WB.Sheets(WB.Sheets.Count))
Set R = S.Range(S.Cells(2, 1), S.Cells(UBound(T, 2) + 1, UBound(T, 1)))
R = Application.Transpose(T)
Set R = S.Range("a1:c1")
R = Array("CLASSEUR", "CLIENT", "MOT RECHERCHE")
R.Font.Bold = True
R.HorizontalAlignment = xlCenter
R.Interior.ColorIndex = 35
S.Cells.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
RESTRICTION
Les classeurs clients doivent être dans le même dossier que le classeur contenant cette macro
et AUCUN autre classeur n'étant pas un classeur clients ne doit s'y trouver.
FONCTIONNEMENT
1) téléchargez l'exemple en pièce jointe pour plus de facilité
2) ouvrez le classeur "Programme" et lancez la macro "RechercheDansClasseurs"
3) renseignez l'InputBox du mot recherché
4) le programme ouvre tous les classeurs et y cherche le mot sélectionné puis affiche le résultat dans une nouvelle feuille
Une piste avec le code suivant à copier dans un module standard
Code:
Sub RechercheDansClasseurs()
Dim FS As FileSearch
Dim WB As Workbook
Dim S As Worksheet
Dim R As Range
Dim Recherche
Dim var
Dim i&
Dim k&
Dim cpt&
Dim A$
Dim T()
Recherche = Application.InputBox( _
prompt:="Tapez le mot recherché.", _
Title:="Recherche dans les classeurs des clients", _
Type:=2)
If Recherche = False Then Exit Sub
Set FS = Application.FileSearch
FS.NewSearch
FS.LookIn = ThisWorkbook.Path
FS.FileType = msoFileTypeExcelWorkbooks
If FS.Execute() = 0 Then Exit Sub
'--- Si classeur déjà ouvert, on sort ---
On Error Resume Next
For i& = 1 To FS.FoundFiles.Count
If FS.FoundFiles(i&) <> ThisWorkbook.FullName Then
Err.Clear
A$ = Mid(FS.FoundFiles(i&), InStrRev(FS.FoundFiles(i&), "\") + 1)
Set WB = Workbooks(A$)
If Err = 0 Then
MsgBox "Le classeur ''" & A$ & "'' est ouvert. Veuillez le fermer."
Exit Sub
End If
End If
Next i&
On Error GoTo 0
'--- Recherche dans les classeurs ---
Application.ScreenUpdating = False
For i& = 1 To FS.FoundFiles.Count
If FS.FoundFiles(i&) <> ThisWorkbook.FullName Then
Set WB = GetObject(FS.FoundFiles(i&))
Set S = WB.Sheets(1)
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[f65536].End(xlUp).Row, 7))
var = R
For k& = 1 To UBound(var, 1)
If Trim(LCase(var(k&, 6))) = Trim(LCase(Recherche)) Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 3, 1 To cpt&)
T(1, cpt&) = WB.Name
T(2, cpt&) = var(3, 3)
T(3, cpt&) = Recherche
End If
Next k&
WB.Close False
Set WB = Nothing
End If
Next i&
Set FS = Nothing
If cpt& = 0 Then
MsgBox "Aucune occurence du mot ''" & Recherche & "'' n'a été trouvé."
Application.ScreenUpdating = True
Exit Sub
End If
'--- Inscription du résultat dans une nouvelle feuille ---
Set WB = ThisWorkbook
Set S = WB.Sheets.Add(after:=WB.Sheets(WB.Sheets.Count))
Set R = S.Range(S.Cells(2, 1), S.Cells(UBound(T, 2) + 1, UBound(T, 1)))
R = Application.Transpose(T)
Set R = S.Range("a1:c1")
R = Array("CLASSEUR", "CLIENT", "MOT RECHERCHE")
R.Font.Bold = True
R.HorizontalAlignment = xlCenter
R.Interior.ColorIndex = 35
S.Cells.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
RESTRICTION
Les classeurs clients doivent être dans le même dossier que le classeur contenant cette macro
et AUCUN autre classeur n'étant pas un classeur clients ne doit s'y trouver.
FONCTIONNEMENT
1) téléchargez l'exemple en pièce jointe pour plus de facilité
2) ouvrez le classeur "Programme" et lancez la macro "RechercheDansClasseurs"
3) renseignez l'InputBox du mot recherché
4) le programme ouvre tous les classeurs et y cherche le mot sélectionné puis affiche le résultat dans une nouvelle feuille
excusez moi de relancer ma demande,
grace a vous la macro correspond a ce que je recherche, mais j'aimerais avoir le resultat affiché dans une listbox ou msgbox au lieu d'une nouvelle feuille
Re : recherche d'une donnee dans fichiers fermes redemande merci
Bonjour,
Voici un nouveau code qui autorise soit l'affichage du résultat dans une nouvelle feuille, soit l'affichage du résultat dans une ListBox OU BIEN les 2 affichages à la fois.
Je ne reviens pas sur l'affichage dans une nouvelle feuille qui a déjà été expliqué lors de mon 1er message.
En ce qui concerne l'affichage dans une ListBox, cette dernière est créée dans un UserForm lui-même créé dynamiquement.
Les constantes suivantes sont à adapter selon votre gré
'### Constantes à adapter ###
Const AFFICHER_DANS_LISTBOX As Boolean = True 'True si on veut afficher le résultat dans une ListBox
Const AFFICHER_DANS_FEUILLE As Boolean = False 'True si on veut afficher le résultat dans une nouvelle feuille
'############################
De plus, la création d'un UserForm dynamique EXIGE deux choses
1) faites, dans le VBE, menu Outils/Références… et chargez la librairie Microsoft Forms 2.0 Object Library
si elle n'est pas dans la liste, faites Parcourir... et cherchez-la dans C:\WINDOWS\system32\FM20.DLL où elle devrait être
2) dans Excel, faites menu Outils/Macro/Sécurité et, dans l'onglet Editeurs approuvés, cochez Faire confiance au projet Visual Basic
Voici le nouveau code
Code:
'############################################
'# Ajouter impérativement la référence #
'# suivante dans Menu Outils/Références #
'# #
'# Microsoft Forms 2.0 Object Library #
'# C:\WINDOWS\system32\FM20.DLL #
'############################################
'### Constantes à adapter ###
Const AFFICHER_DANS_LISTBOX As Boolean = True 'True si on veut afficher le résultat dans une ListBox
Const AFFICHER_DANS_FEUILLE As Boolean = False 'True si on veut afficher le résultat dans une nouvelle feuille
'############################
Const LARGEUR_UF As Double = 320
Const HAUTEUR_UF As Double = 240
Const MARGE_UF As Double = 20
Public DataListBox As Variant
Sub RechercheDansClasseurs_2()
Dim FS As FileSearch
Dim WB As Workbook
Dim S As Worksheet
Dim R As Range
Dim Recherche
Dim var
Dim i&
Dim k&
Dim cpt&
Dim A$
Dim T()
Dim bool As Boolean
Recherche = Application.InputBox( _
prompt:="Tapez le mot recherché.", _
Title:="Recherche dans les classeurs des clients", _
Type:=2)
If Recherche = False Then Exit Sub
Set FS = Application.FileSearch
FS.NewSearch
FS.LookIn = ThisWorkbook.Path
FS.FileType = msoFileTypeExcelWorkbooks
If FS.Execute() = 0 Then Exit Sub
'--- Si classeur déjà ouvert, on sort ---
On Error Resume Next
For i& = 1 To FS.FoundFiles.Count
If FS.FoundFiles(i&) <> ThisWorkbook.FullName Then
Err.Clear
A$ = Mid(FS.FoundFiles(i&), InStrRev(FS.FoundFiles(i&), "\") + 1)
Set WB = Workbooks(A$)
If Err = 0 Then
MsgBox "Le classeur ''" & A$ & "'' est ouvert. Veuillez le fermer."
Exit Sub
End If
End If
Next i&
On Error GoTo 0
'--- Recherche dans les classeurs ---
Application.ScreenUpdating = False
For i& = 1 To FS.FoundFiles.Count
If FS.FoundFiles(i&) <> ThisWorkbook.FullName Then
Set WB = GetObject(FS.FoundFiles(i&))
Set S = WB.Sheets(1)
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[f65536].End(xlUp).Row, 7))
var = R
For k& = 1 To UBound(var, 1)
If Trim(LCase(var(k&, 6))) = Trim(LCase(Recherche)) Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 3, 1 To cpt&)
T(1, cpt&) = WB.Name
T(2, cpt&) = var(3, 3)
T(3, cpt&) = Recherche
End If
Next k&
WB.Close False
Set WB = Nothing
End If
Next i&
Set FS = Nothing
If cpt& = 0 Then
MsgBox "Aucune occurence du mot ''" & Recherche & "'' n'a été trouvé."
Application.ScreenUpdating = True
Exit Sub
End If
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
'°°° Inscription du résultat dans une nouvelle feuille °°°
If AFFICHER_DANS_FEUILLE Then
Set WB = ThisWorkbook
Set S = WB.Sheets.Add(after:=WB.Sheets(WB.Sheets.Count))
Set R = S.Range(S.Cells(2, 1), S.Cells(UBound(T, 2) + 1, UBound(T, 1)))
R = Application.Transpose(T)
Set R = S.Range("a1:c1")
R = Array("CLASSEUR", "CLIENT", "MOT RECHERCHE")
R.Font.Bold = True
R.HorizontalAlignment = xlCenter
R.Interior.ColorIndex = 35
S.Cells.Columns.AutoFit
End If
'°°° Inscription du résultat dans un UserForm ListBox °°°
If AFFICHER_DANS_LISTBOX Then
DataListBox = Application.Transpose(T)
bool = UserForm_aLaVolee
Application.ScreenUpdating = True
End If
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
Application.ScreenUpdating = True
End Sub
Private Function UserForm_aLaVolee() As Boolean
Dim UF As Object
Dim LB As MSForms.ListBox
Dim CB As MSForms.CommandButton
Dim A$
Dim nbCol&
Dim i&
On Error GoTo Erreur
'--- Crée dynamiquement un UserForm ---
Set UF = ThisWorkbook.VBProject.VBComponents.Add(3)
With UF
.Properties("Caption") = "Mots trouvés"
.Properties("Height") = HAUTEUR_UF
.Properties("Width") = LARGEUR_UF
End With
'--- Crée le bouton de fermeture ---
Set CB = UF.Designer.Controls.Add("forms.CommandButton.1")
With CB
.Caption = "Fermer"
.Left = (LARGEUR_UF - CB.Width) / 2
.Top = HAUTEUR_UF - (3 * MARGE_UF)
End With
'--- Crée la ListBox ---
Set LB = UF.Designer.Controls.Add("forms.ListBox.1")
With LB
nbCol& = UBound(DataListBox, 2)
.Left = MARGE_UF
.Top = MARGE_UF
.Height = CB.Top - (2 * MARGE_UF)
.Width = LARGEUR_UF - (2 * MARGE_UF)
.ColumnCount = nbCol&
.BoundColumn = 1
'°°° Calcul de ColumnWidths °°°
For i& = 1 To nbCol&
A$ = A$ & (.Width - nbCol&) \ nbCol& & ";"
Next i&
.ColumnWidths = Mid(A$, 1, Len(A$) - 1)
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
.BackColor = &HC0E0FF
.BorderStyle = fmBorderStyleSingle
End With
'°°° Ajout du code évènementiel °°°
A$ = "Sub CommandButton1_Click()" & _
vbCrLf & "Unload Me" & _
vbCrLf & "End Sub" & _
vbCrLf & "Sub UserForm_Initialize()" & _
vbCrLf & "ListBox1.List=DataListBox" & _
vbCrLf & "End Sub"
With UF.codemodule
i& = .CountOfLines
.insertlines i& + 1, A$
End With
'--- Affiche le UserForm ---
VBA.UserForms.Add(UF.Name).Show
'--- Détruit le UserForm ---
Erreur:
If Not UF Is Nothing Then ThisWorkbook.VBProject.VBComponents.Remove UF
If Err <> 0 Then UserForm_aLaVolee = True
End Function
Voici un nouveau code qui autorise soit l'affichage du résultat dans une nouvelle feuille, soit l'affichage du résultat dans une ListBox OU BIEN les 2 affichages à la fois.
Je ne reviens pas sur l'affichage dans une nouvelle feuille qui a déjà été expliqué lors de mon 1er message.
En ce qui concerne l'affichage dans une ListBox, cette dernière est créée dans un UserForm lui-même créé dynamiquement.
Les constantes suivantes sont à adapter selon votre gré
De plus, la création d'un UserForm dynamique EXIGE deux choses
1) faites, dans le VBE, menu Outils/Références… et chargez la librairie Microsoft Forms 2.0 Object Library
si elle n'est pas dans la liste, faites Parcourir... et cherchez-la dans C:\WINDOWS\system32\FM20.DLL où elle devrait être
2) dans Excel, faites menu Outils/Macro/Sécurité et, dans l'onglet Editeurs approuvés, cochez Faire confiance au projet Visual Basic
Voici le nouveau code
Code:
'############################################
'# Ajouter impérativement la référence #
'# suivante dans Menu Outils/Références #
'# #
'# Microsoft Forms 2.0 Object Library #
'# C:\WINDOWS\system32\FM20.DLL #
'############################################
'### Constantes à adapter ###
Const AFFICHER_DANS_LISTBOX As Boolean = True 'True si on veut afficher le résultat dans une ListBox
Const AFFICHER_DANS_FEUILLE As Boolean = False 'True si on veut afficher le résultat dans une nouvelle feuille
'############################
Const LARGEUR_UF As Double = 320
Const HAUTEUR_UF As Double = 240
Const MARGE_UF As Double = 20
Public DataListBox As Variant
Sub RechercheDansClasseurs_2()
Dim FS As FileSearch
Dim WB As Workbook
Dim S As Worksheet
Dim R As Range
Dim Recherche
Dim var
Dim i&
Dim k&
Dim cpt&
Dim A$
Dim T()
Dim bool As Boolean
Recherche = Application.InputBox( _
prompt:="Tapez le mot recherché.", _
Title:="Recherche dans les classeurs des clients", _
Type:=2)
If Recherche = False Then Exit Sub
Set FS = Application.FileSearch
FS.NewSearch
FS.LookIn = ThisWorkbook.Path
FS.FileType = msoFileTypeExcelWorkbooks
If FS.Execute() = 0 Then Exit Sub
'--- Si classeur déjà ouvert, on sort ---
On Error Resume Next
For i& = 1 To FS.FoundFiles.Count
If FS.FoundFiles(i&) <> ThisWorkbook.FullName Then
Err.Clear
A$ = Mid(FS.FoundFiles(i&), InStrRev(FS.FoundFiles(i&), "\") + 1)
Set WB = Workbooks(A$)
If Err = 0 Then
MsgBox "Le classeur ''" & A$ & "'' est ouvert. Veuillez le fermer."
Exit Sub
End If
End If
Next i&
On Error GoTo 0
'--- Recherche dans les classeurs ---
Application.ScreenUpdating = False
For i& = 1 To FS.FoundFiles.Count
If FS.FoundFiles(i&) <> ThisWorkbook.FullName Then
Set WB = GetObject(FS.FoundFiles(i&))
Set S = WB.Sheets(1)
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[f65536].End(xlUp).Row, 7))
var = R
For k& = 1 To UBound(var, 1)
If Trim(LCase(var(k&, 6))) = Trim(LCase(Recherche)) Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 3, 1 To cpt&)
T(1, cpt&) = WB.Name
T(2, cpt&) = var(3, 3)
T(3, cpt&) = Recherche
End If
Next k&
WB.Close False
Set WB = Nothing
End If
Next i&
Set FS = Nothing
If cpt& = 0 Then
MsgBox "Aucune occurence du mot ''" & Recherche & "'' n'a été trouvé."
Application.ScreenUpdating = True
Exit Sub
End If
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
'°°° Inscription du résultat dans une nouvelle feuille °°°
If AFFICHER_DANS_FEUILLE Then
Set WB = ThisWorkbook
Set S = WB.Sheets.Add(after:=WB.Sheets(WB.Sheets.Count))
Set R = S.Range(S.Cells(2, 1), S.Cells(UBound(T, 2) + 1, UBound(T, 1)))
R = Application.Transpose(T)
Set R = S.Range("a1:c1")
R = Array("CLASSEUR", "CLIENT", "MOT RECHERCHE")
R.Font.Bold = True
R.HorizontalAlignment = xlCenter
R.Interior.ColorIndex = 35
S.Cells.Columns.AutoFit
End If
'°°° Inscription du résultat dans un UserForm ListBox °°°
If AFFICHER_DANS_LISTBOX Then
DataListBox = Application.Transpose(T)
bool = UserForm_aLaVolee
Application.ScreenUpdating = True
End If
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
Application.ScreenUpdating = True
End Sub
Private Function UserForm_aLaVolee() As Boolean
Dim UF As Object
Dim LB As MSForms.ListBox
Dim CB As MSForms.CommandButton
Dim A$
Dim nbCol&
Dim i&
On Error GoTo Erreur
'--- Crée dynamiquement un UserForm ---
Set UF = ThisWorkbook.VBProject.VBComponents.Add(3)
With UF
.Properties("Caption") = "Mots trouvés"
.Properties("Height") = HAUTEUR_UF
.Properties("Width") = LARGEUR_UF
End With
'--- Crée le bouton de fermeture ---
Set CB = UF.Designer.Controls.Add("forms.CommandButton.1")
With CB
.Caption = "Fermer"
.Left = (LARGEUR_UF - CB.Width) / 2
.Top = HAUTEUR_UF - (3 * MARGE_UF)
End With
'--- Crée la ListBox ---
Set LB = UF.Designer.Controls.Add("forms.ListBox.1")
With LB
nbCol& = UBound(DataListBox, 2)
.Left = MARGE_UF
.Top = MARGE_UF
.Height = CB.Top - (2 * MARGE_UF)
.Width = LARGEUR_UF - (2 * MARGE_UF)
.ColumnCount = nbCol&
.BoundColumn = 1
'°°° Calcul de ColumnWidths °°°
For i& = 1 To nbCol&
A$ = A$ & (.Width - nbCol&) \ nbCol& & ";"
Next i&
.ColumnWidths = Mid(A$, 1, Len(A$) - 1)
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
.BackColor = &HC0E0FF
.BorderStyle = fmBorderStyleSingle
End With
'°°° Ajout du code évènementiel °°°
A$ = "Sub CommandButton1_Click()" & _
vbCrLf & "Unload Me" & _
vbCrLf & "End Sub" & _
vbCrLf & "Sub UserForm_Initialize()" & _
vbCrLf & "ListBox1.List=DataListBox" & _
vbCrLf & "End Sub"
With UF.codemodule
i& = .CountOfLines
.insertlines i& + 1, A$
End With
'--- Affiche le UserForm ---
VBA.UserForms.Add(UF.Name).Show
'--- Détruit le UserForm ---
Erreur:
If Not UF Is Nothing Then ThisWorkbook.VBProject.VBComponents.Remove UF
If Err <> 0 Then UserForm_aLaVolee = True
End Function
Ce site utilise des cookies pour personnaliser le contenu, adapter votre expérience et vous garder connecté si vous vous enregistrez.
En continuant à utiliser ce site, vous consentez à notre utilisation de cookies.
merci pour ta réponse je test la macro et te tiens au courant
