boucle sur filesearch comprenant un autre filesearch

[armelle1303]

bonsoir à tous
comme vous le doutez si je suis là c'est parce que je ne trouve pas la solution :
lorsque j'exécute ma 1ère boucle, pour I = 1 mon code fonctionne mais lorsque je valide Next I , il me renvoie "l'indice n'appartient pas à la sélection" à la ligne msgbox... juste après For I= 1 to ....
donc il ne trouve pas le 2èmé fichier trouvé (enfin je crois).
est ce que c'est parce que j'ai fait un 2ème FileSearch qui ne me trouve qu'un fichier et il a donc mis la valeur à 1.
Si oui , savez vous comment faire pour éviter ceci ou remettre found files au nombre d'origine
j'ai essayé en mettant avant le nbr de found files dans une variable mais cela ne marche pas où alors il faudrait peut être mettre tous les chemins dans une variable avec une boucle et ....ouhhlà des boucles partout je m'emmêle les pinceaux.

but du code : je recherche tous les fichiers.dft d'un répertoire et regarde si il existe un fichier au même nom mais en pdf, si oui je compare les dates de création , si identiques RAS, sinon je récupère le chemin du fichier dans la feuille Excel.

Bon voilà j'espère avoir été claire et avoir plus de chances qu'avec mes derniers posts qui n'ont pas eu beaucoup de succès

j'ai vu un post sur la réinitialisation de filesearch mais ce n'était pas le même pb. apparemment il n'y avait pas de solution et il a fallut contourner le pb.
en dernier recours c'est ce que j'essaierai de faire pour n'avoir qu'un Filesearch mais cela va compliquer mon code alors si on peut faire simple pourquoi s'en priver.

Sub compareFichier()

Dim ScanFic As Office.FileSearch
Dim Nbr As Long
Dim I As Long, K As Long
Dim DernLig As Long
Dim FileItem, FileItem2
Dim FSO As Scripting.FileSystemObject
Dim Fl As Scripting.File

repertoire = ThisWorkbook.Path
'attention : adapter le repertoire à chaque poste de travail

Sheets(1).Activate: Sheets(1).Select: Cells.Clear
  Cells(1, 1).Value = "Tous les fichiers dft  ci-dessous n'ont pas de copie en pdf pour la diffusion"
  Cells(1, 2).Value = Now
  
Set ScanFic = Application.FileSearch
With ScanFic
.NewSearch
.LookIn = repertoire
.SearchSubFolders = True
.MatchTextExactly = False
.Filename = "*.dft"

If .Execute > 0 Then
    
    Nbr = .Execute
    Application.ScreenUpdating = False
    

 For I = 1 To .FoundFiles.Count
    MsgBox Application.FileSearch.FoundFiles(I) 'pour prog
    FileItem = .FoundFiles(I)
    Set FSO = New Scripting.FileSystemObject
    nomFich = FSO.GetBaseName(FileItem)
    Set File = FSO.GetFile(FileItem)
    datCr = File.DateCreated
     dateCrea = VBA.Left(datCr, 10)
            'pour chaque fichier trouvé , recherche si existe avec même nom mais en .pdf
            Set ScanFic2 = Application.FileSearch
                With ScanFic2
                    .NewSearch
                    .LookIn = repertoire
                    .SearchSubFolders = True
                    .MatchTextExactly = True
                    .Filename = nomFich & ".pdf"
                   
                    If .Execute > 0 Then
                        Nbr1 = .Execute
                        MsgBox Application.FileSearch.Filename
                        'compare les dates
                        For K = 1 To .FoundFiles.Count
                        FileItem2 = .FoundFiles(K)
                        Set File2 = FSO.GetFile(FileItem2)
                        MsgBox File2
                        datCr2 = File2.DateCreated
                         dateCrea2 = VBA.Left(datCr2, 10)
                        If dateCrea2 <> dateCrea Then
                            Sheets(1).Select
                            DernLig = Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row + 1
                            Cells(DernLig, 1) = File.Path
                            Else
                            GoTo 1:
                        End If
                        Next K
                     Else
                     GoTo 1:
                     
                    End If
                  
                End With
1:

Next I
 
    If DernLig > 2 Then
    Range("A2:F" & DernLig).Select 'tri sur base col A
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    ActiveSheet.Columns.AutoFit: Range("A1").Select
    End If
Set FileItem = Nothing

End If

End With


End Sub

 

[kjin]

Re : boucle sur filesearch comprenant un autre filesearch

Bonsoir,
Pas vraiment compris quoi faire si le fichier est non trouvé et si date identique...
(le "Goto 1" en question)

Sub compareFichier()
Dim fso, fs

repertoire = ThisWorkbook.Path
'attention : adapter le repertoire à chaque poste de travail
Application.ScreenUpdating = False
'Sheets(1).Activate: Sheets(1).Select: Cells.Clear
'Cells(1, 1).Value = "Tous les fichiers dft  ci-dessous n'ont pas de copie en pdf pour la diffusion"
'Cells(1, 2).Value = Now

Set fso = CreateObject("Scripting.FileSystemObject")
Set fs = Application.FileSearch
With fs
    .NewSearch
    .LookIn = repertoire
    .SearchSubFolders = True
    .MatchTextExactly = False
    .Filename = "*.dft"
    .Execute
    For i = 1 To .FoundFiles.Count
        oFile1 = .FoundFiles(i)
        sFile1 = fso.GetBaseName(oFile1)
        Set pFile1 = fso.GetFile(oFile1)
        dFile1 = CDate(Format(pFile1.DateCreated, "dd/mm/yy"))
        'pour chaque fichier trouvé , recherche si existe avec même nom mais en .pdf
        oFile2 = repertoire & "\" & sFile1 & ".pdf"
        If fso.FileExists(oFile2) Then
            sFile2 = fso.GetBaseName(oFile2)
            Set pFile2 = fso.GetFile(oFile2)
            dFile2 = CDate(Format(pFile2.DateCreated, "dd/mm/yy"))
            If dFile2 <> dFile1 Then
                With Sheets(1)
                    .Range("A65000").End(xlUp).Offset(1, 0) = oFile2
                End With
            End If
        End If
    Next i
End With
Set fs = Nothing
Set fso = Nothing

End Sub

Pour ma part, écrire en noir me convient très mieux
A+
kjin

 

[Staple1600]

Re : boucle sur filesearch comprenant un autre filesearch

Bonsoir


Avec CreateObject("Scripting.FileSystemObject")
ici pour lister les *.pdf et *.dft

(reste à traiter les dates)

Option Explicit
Sub test()
Dim sFiles() As String
Dim lCtr As Long
sFiles = AllFiles("C:\Temp", "pdf", "dft")
Range("A1").Resize(UBound(sFiles)) = Application.Transpose(sFiles)
End Sub

Private Function AllFiles(ByVal FullPath$, ext1$, ext2$) As String()
'adapté de :http://www.freevbcode.com/ShowCode.Asp?ID=1487
Dim oFs, t
Dim sAns() As String
Dim oFolder
Dim oFile
Dim lElement As Long
 Set oFs = CreateObject("Scripting.FileSystemObject")
ReDim sAns(0) As String
If oFs.FolderExists(FullPath) Then
    Set oFolder = oFs.GetFolder(FullPath)
 
    For Each oFile In oFolder.Files
    t = Split(oFile, ".")
    If t(UBound(t)) Like ext1 Or t(UBound(t)) Like ext2 Then
      lElement = IIf(sAns(0) = "", 0, lElement + 1)
      ReDim Preserve sAns(lElement) As String
      sAns(lElement) = oFile.Name
      End If
    Next
End If
AllFiles = sAns
ErrHandler:
    Set oFs = Nothing
    Set oFolder = Nothing
    Set oFile = Nothing
End Function

EDITION: désolé pas rafraichi, bonsoir kjin

 

[kiki29]

Re : boucle sur filesearch comprenant un autre filesearch

Salut, et une de plus , te restera l'histoire des dates

 

[armelle1303]

Re : boucle sur filesearch comprenant un autre filesearch

bonjour Kiki29, Stapple1600, Kjin

d'abord merci pour vos réponses rapides

Kiki : j'avais déja ce fichier qui m'a inspirée pour autre chose d'ailleurs mais là ne correspond à mon pb (enfin pas suffisant).

Staple : Merci pour ton code , cela m'apprends une nouvelle façon de travailler mais je veux pourvior aller dans les dossiers sous dossiers, rechercher un dft et rechercher si il existe le même en pdf, si oui comparer les dates de création. si identiques, ne rien faire, si différentes inscrire le chemin sur la feuille active. si pas de fichier inscrire aussi sur la feuille active.

Kjin :
Merci pour ton code il est génial : plus simple, plus propre... et correspond tout à fait à ce que je cherchais. je n'avais pas pensé à FileExist , à retenir
pour l'écriture en ruge, je voulais juste mettre la ligne qui plantait mais cela a fait quelque chose de bizarre et je n'ai pas réussi à remettre tout en noir (faut dire que je n'ai pas chercher trop longtemps).
Je ferai plus d'efforts la prochaine fois pour vous rendre la lecture moins désagréable.



Voilà Encore merci; ce bout de code était l'élément final de mon projet. je vais pourvoir mettre en oeuvre le projet complet (sous réserves des bugs de dernière minute bien sûr).

A bientôt sur le fil

Armelle