Bonsoir,
à tester et améliorer
Sub cherc()
Application.ScreenUpdating = False
Set fs = Application.FileSearch
With fs
.LookIn = "N:\mes telechargements\ingenieurcesi"
.Filename = "tec*.xls"
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(i)
sonnom = ActiveWorkbook.Name
Dim wkbsh1 As Worksheet
Set wkbsh1 = Workbooks("hardware.xls" ).Sheets(1)
Set wkbsh2 = ActiveSheet
nbli = wkbsh2.Range("A65534" ).End(xlUp).Row
For j = 2 To nbli
With wkbsh1.Range("a2:a65534" )
atrouver = wkbsh2.Cells(j, 1).Value
Set c = .Find(atrouver, LookIn:=xlValues)
If Not c Is Nothing Then
ligneexiste = c.Row
wkbsh1.Cells(ligneexiste, i + 1) = wkbsh2.Cells(j, 2).Value
Else
derligne = wkbsh1.Range("A65534" ).End(xlUp).Row + 1
wkbsh1.Cells(derligne, 1) = wkbsh2.Cells(j, 1).Value
wkbsh1.Cells(derligne, i + 1) = wkbsh2.Cells(j, 2).Value
End If
wkbsh1.Cells(1, i + 1) = Left(sonnom, Len(sonnom) - 4)
End With
Next j
Workbooks(sonnom).Close savechanges:=False
Next i
wkbsh1.Activate
Else
MsgBox "pas de fichiers"
End If
End With
Application.ScreenUpdating = True
End Sub
Je n'ai pas classé par date à la fin.
Cordialement
Message édité par seniorpapou le 30-01-2007 à 22:09:02