XL 2016 Problème "Application Filesearch" excel 2016

[fenec]

Bonjour le forum,
Venant de passer d'office 2003 à office 2016, je rencontre un problème avec une macro que j'utilise depuis une dizaine d'année.
En effet en cherchant sur le net le pourquoi, j'ai lu que "Filesearch" n'est plus pris en compte sur excel 2016.
C'est donc le but de ma demande car je ne parviens pas à modifier mon code pour qu'il fonctionne à nouveau.
J'ai cru comprendre qu'il fallait utiliser "fso" mais la je coince d'où besoin de votre aide sur ce point.
Voici le code en question:

Sub Editer_BdC()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveSheet.Unprotect Password:="1012"
      
Range("O3") = (1 + CInt(Range("O3"))) Mod 2
    For Each Shp In ActiveSheet.Shapes
    If InStr(Shp.Name, "Bon de commande") Then
    Shp.Visible = Range("O3") = 1
    Next Shp
    
Dim Recf, Compar, Y, Msg
On Error GoTo Fin
    Set Recf = Application.FileSearch
    With Recf
    Compar = InputBox("Fichiers dont le nom commence par :" & _
    Chr(13) & "(saisissez * pour obtenir tous les " & _
    "classeurs du répertoire)", "Classeurs commençant par...")
    If Compar <> "" Then
    .LookIn = "C:\Users\Philippe\Mes documents\Archives\Devis"
    .Filename = Compar & "*.*"
    If .Execute > 0 Then
    MsgBox .FoundFiles.Count & " fichier(s) trouvé(s)."
    For Y = 1 To .FoundFiles.Count
        If MsgBox("Voulez-vous ouvrir " & _
        .FoundFiles(Y), vbYesNo) = vbYes Then
        Workbooks.Open (.FoundFiles(Y))
        mavariable = ActiveWorkbook.Name
        End If
    Next Y
    Else
    Msg = MsgBox("Aucun fichier correspondant à la " & _
"recherche.", , "Désolé...")

Fin:  MontrerMasquer
    Exit Sub
 End If
 End If
 End With
    Range("E14:E18,I16:I17,C21:C34,E21:E34,G21:G34,G37,H21:H34,I36,H39:H40,H42:H43,H46").Select
 
  For Each cel In Selection
  cel.Copy
  Windows("FC M Isolation 2.0.xls").Activate
  Sheets("Devis - BdC").Select
  Range(cel.Address).Select
  ActiveSheet.Paste
  Next cel
 
  Range("I14").Select

  Windows(mavariable).Activate
  ActiveWorkbook.Close Savechanges:=True
 
ActiveSheet.Protect Password:="1012"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Merci d'avance pour l'aide que je vous pourriez m'apporter pour modifier ce code.
Cordialement,
Philippe.

 

[jmfmarques]

Bonjour

Nouveau code pour "Application.FileSearch"

Bonjour, Dans Excel 2003, j'avais une macro qui fonctionnait fort bien et qui utilisait le code suivant : With Application.FileSearch .LookIn = Dossier .SearchSubFolders = True End With Avec Excel 2010, ma macro ne fonctionne plus et se bloque sur "With Application.File Search"...

www.excel-downloads.com

 

[fenec]

Bonjour le forum, jmfmarques
Désolé pour la réponse tardive.
Merci pour ce lien je j'avais trouvé mais malgré celui-ci je n'y parviens pas ,c'est d'ailleurs pour cela que je sollicitais votre aide.
On parle de macro complémentaire mais qui ne marche plus non plus avec excel 2016.
Je constate en plus que beaucoup de code ne fonctionnent plus sous 2016 et je commence à regretter excel 2003 mais il fallait bien changer un jour.
Cordialement,
Philippe.

 

[Dranreb]

Bonjour
Essayez cette séquence :

Dim Profil As String, NomFic As String
Profil = InputBox("Fichiers dont le nom commence par :" & _
   vbLf & "(saisissez * pour obtenir tous les " & _
   "classeurs du répertoire)", "Classeurs commençant par...")
Select Case Profil
   Case "": Exit Sub: Case "*": Profil = "*.*"
   Case Else: Profil = Profil & "*.*": End Select
ChDrive "C": ChDir "C:\Users\Philippe\Mes documents\Archives\Devis"
NomFic = Dir(Profil)
If NomFic = "" Then MsgBox "Aucun ficher de la forme """ & Profil & """ sur" _
   & vbLf & CurDir, vbCritical: Exit Sub
Do: If MsgBox("Voulez-vous ouvrir """ & NomFic & """ ?", _
      vbYesNo) = vbYes Then Workbooks.Open NomFic
   NomFic = Dir: Loop Until NomFic = ""

 

[Dranreb]

Je dirais même plus :

Sub Editer_BdC()
   Dim Profil As String, NomFic As String, ClnNF As New Collection, TInput() As String, N As Long, _
      Rép As String, WshCbl As Worksheet, WbkSrc As Workbook, RngSrc As Range, RngZon As Range
   Profil = InputBox("Fichiers dont le nom commence par :" & vbLf & "(Saisissez * pour obtenir tous les classeurs de" _
      & vbLf & CurDir & ")", "Classeurs commençant par...")
   Select Case Profil
      Case "": Exit Sub: Case "*": Profil = "*.*"
      Case Else: Profil = Profil & "*.*": End Select
   ChDrive "C": ChDir "C:\Users\Philippe\Mes documents\Archives\Devis"
   NomFic = Dir(Profil)
   While NomFic <> "": ClnNF.Add NomFic: NomFic = Dir: Wend
   Select Case ClnNF.Count
      Case 0: MsgBox "Aucun ficher de la forme """ & Profil & """ sur" _
            & vbLf & CurDir, vbCritical: Exit Sub
      Case 1: NomFic = ClnNF(1)
         If MsgBox("(Au " & Format(FileDateTime(NomFic), "dd/mm/yyyy hh:mm") _
            & "): " & NomFic, vbOKCancel, "Ouvrir") = vbCancel Then Exit Sub
      Case Else: ReDim TInput(0 To ClnNF.Count + 1)
         TInput(0) = "Quel fichier voulez vous ouvrir ?"
         For N = 1 To ClnNF.Count: NomFic = ClnNF(N)
            TInput(N) = N & " — (" & Format(FileDateTime(NomFic), "dd/mm/yyyy hh:mm") _
               & "): " & NomFic: Next N
         TInput(N) = "Entrez un N°:"
         Rép = InputBox(Join(TInput, vbLf), "Ouvrir"): If IsNumeric(Rép) Then N = CLng(Rép)
         If N < 1 Or N > ClnNF.Count Then Exit Sub
         NomFic = ClnNF(N): End Select
   Set WshCbl = ActiveSheet
   Set WbkSrc = Workbooks.Open(NomFic)
   Set RngSrc = ActiveSheet.Range("E14:E18,I16:I17,C21:C34,E21:E34,G21:G34,G37,H21:H34,I36,H39:H40,H42:H43,H46")
   For Each RngZon In RngSrc.Areas
   '   RngZon.Copy Destination:=WshCbl.Range(RngZon.Address) ' pour prendre formules et formats
      WshCbl.Range(RngZon.Address).Value = RngZon.Value ' pour ne prendre que les valeurs
      Next RngZon
   WbkSrc.Close Savechanges:=False
   End Sub
   '   RngZon.Copy Destination:=WshCbl.Range(RngZon.Address) ' pour prendre formules et formats
      WshCbl.Range(RngZon.Address).Value = RngZon.Value ' pour ne prendre que les valeurs
      Next RngZon
   WbkSrc.Close Savechanges:=False
   End Sub

 

[fenec]

Re le forum et bonjour Dranreb
Déjà un grand merci pour tes réponses, je regarde et me permet de revenir pour te tenir au courant.
Cordialement ,
Philippe.

 

[fenec]

Bonjour le forum, Dranreb
Votre code à l'air de fonctionner après plusieurs essais mais pourriez vous me le commenter car je ne comprends pas vos variables car elle sont abrégées, c'est facile pour vous puisque vous êtes l'auteur du code, d'avance merci.

Un deuxième petit soucis:
Voulant rajouter cette partie de mon ancienne macro cette partie bloque sur "next sans for" est ce du aussi à excel 2016 qui ne prend pas les shapes en compte?

Range("O3") = (1 + CInt(Range("O3"))) Mod 2
    For Each Shp In ActiveSheet.Shapes
           If InStr(Shp.Name, "Bon de commande") Then
           Shp.Visible = Range("O3") = 1
    Next Shp

Merci d'avance .
Cordialement,
Philippe.

 

[jmfmarques]

Bonjour
ce qui manque, c'est très visiblement un End If

 

[Dranreb]

Bonsoir
Avec la liste des trigrammes préfixes que j'emploie systématiquement pour les noms de variables objets, est-ce que ça va mieux (sachant que j'ai aussi pris comme suffixes Src pour Source et Cbl pour Cible) ?

Vous remarquerez qu'il n'y a que 2 règles et 29% d'exceptions.