M
Manon
Guest
Bonjour à tous
J'ai réussi à monter un petit programme grâce à l'aide de plusieurs d'entre vous.
Il a bien fonctionné pendant longtemps.
Je l'ai sauvegardé sur une disquette et installé sur un autre poste XP.
Curieusement, sur mon poste(XP aussi), il me donne maintenant une erreur: Incompatibilité de type erreur13.
Fonctionne cependant très bien sur le 2e poste.
Qu'est-ce qui se passe ????
------------------------------
Mon code:
'bouton mise à jour client
Sub lancer()
Dim noms_de_fichiers As Variant, i As Integer, y As Integer
Application.ScreenUpdating = False
ChDrive 'D' 'Modifie la lettre du lecteur
ChDir 'D:\\Clients' 'Modifie le répertoire
noms_de_fichiers = créer_liste_fichiers('*.xls')
Workbooks('Gestion.xls').Activate 'Modifie le nom du classeur
Sheets('Clients').Select 'Modifie le nom de la feuille
Range('A1', Range('A1').End(xlDown)).Select
Selection.ClearContents
Range('A1').Select
'code afin que le chemin du dossier
'et les extensions du fichier ne soient pas visible
For i = 1 To UBound(noms_de_fichiers)...............ERREUR CODE 13
Cells(i, 1).Formula = Mid(noms_de_fichiers(i), 16, Len(noms_de_fichiers(i)) - 19) '
Next i
Dim currentcell, nextcell
Set currentcell = Worksheets('Gestion').Range('A1') 'Modifie le nom de la feuille
Do While Not IsEmpty(currentcell)
Dim nom_fichier
Set nextcell = currentcell.Offset(1, 0)
nom_fichier = currentcell.Value
For y = 1 To ActiveWorkbook.Sheets.Count
'Dans la ligne ci-dessous modifie éventuellement les noms de classeur et de feuille
Next y
Set currentcell = nextcell
Loop
Application.ScreenUpdating = True
Worksheets('Gestion').Select
End Sub
Public Function créer_liste_fichiers(Filtre As String)
'===========================================================================
'Fonction permettant de générer une liste des fichiers présents dans le
'répertoire courant
'Cette liste va être générée dans la procédure Lancer
'===========================================================================
Dim listefichiers() As String, comptefichier As Long
créer_liste_fichiers = ''
Erase listefichiers
If Filtre = '' Then Filtre = '*.xls,es1'
With Application.FileSearch
.NewSearch
.LookIn = CurDir
.Filename = Filtre
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
If .Execute(SortBy:=msoSortByFileName, _
sortorder:=msoSortOrderAscending) = 0 Then Exit Function
ReDim listefichiers(.FoundFiles.Count)
For comptefichier = 1 To .FoundFiles.Count
listefichiers(comptefichier) = .FoundFiles(comptefichier)
Next comptefichier
.FileType = msoFileTypeExcelWorkbooks
End With
créer_liste_fichiers = listefichiers
Erase listefichiers
End Function
Merci à tous
Manon
J'ai réussi à monter un petit programme grâce à l'aide de plusieurs d'entre vous.
Il a bien fonctionné pendant longtemps.
Je l'ai sauvegardé sur une disquette et installé sur un autre poste XP.
Curieusement, sur mon poste(XP aussi), il me donne maintenant une erreur: Incompatibilité de type erreur13.
Fonctionne cependant très bien sur le 2e poste.
Qu'est-ce qui se passe ????
------------------------------
Mon code:
'bouton mise à jour client
Sub lancer()
Dim noms_de_fichiers As Variant, i As Integer, y As Integer
Application.ScreenUpdating = False
ChDrive 'D' 'Modifie la lettre du lecteur
ChDir 'D:\\Clients' 'Modifie le répertoire
noms_de_fichiers = créer_liste_fichiers('*.xls')
Workbooks('Gestion.xls').Activate 'Modifie le nom du classeur
Sheets('Clients').Select 'Modifie le nom de la feuille
Range('A1', Range('A1').End(xlDown)).Select
Selection.ClearContents
Range('A1').Select
'code afin que le chemin du dossier
'et les extensions du fichier ne soient pas visible
For i = 1 To UBound(noms_de_fichiers)...............ERREUR CODE 13
Cells(i, 1).Formula = Mid(noms_de_fichiers(i), 16, Len(noms_de_fichiers(i)) - 19) '
Next i
Dim currentcell, nextcell
Set currentcell = Worksheets('Gestion').Range('A1') 'Modifie le nom de la feuille
Do While Not IsEmpty(currentcell)
Dim nom_fichier
Set nextcell = currentcell.Offset(1, 0)
nom_fichier = currentcell.Value
For y = 1 To ActiveWorkbook.Sheets.Count
'Dans la ligne ci-dessous modifie éventuellement les noms de classeur et de feuille
Next y
Set currentcell = nextcell
Loop
Application.ScreenUpdating = True
Worksheets('Gestion').Select
End Sub
Public Function créer_liste_fichiers(Filtre As String)
'===========================================================================
'Fonction permettant de générer une liste des fichiers présents dans le
'répertoire courant
'Cette liste va être générée dans la procédure Lancer
'===========================================================================
Dim listefichiers() As String, comptefichier As Long
créer_liste_fichiers = ''
Erase listefichiers
If Filtre = '' Then Filtre = '*.xls,es1'
With Application.FileSearch
.NewSearch
.LookIn = CurDir
.Filename = Filtre
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
If .Execute(SortBy:=msoSortByFileName, _
sortorder:=msoSortOrderAscending) = 0 Then Exit Function
ReDim listefichiers(.FoundFiles.Count)
For comptefichier = 1 To .FoundFiles.Count
listefichiers(comptefichier) = .FoundFiles(comptefichier)
Next comptefichier
.FileType = msoFileTypeExcelWorkbooks
End With
créer_liste_fichiers = listefichiers
Erase listefichiers
End Function
Merci à tous
Manon