WDAndCo
XLDnaute Impliqué
Bonjour le Forum
1) - J'ai un probleme avec un classeur, voir la copie d'écran, ce classeur fonctionne sans probleme sur d'autres machines. Pourquoi ?
2) - J'ai le code qui suit (celui qui me pose probleme) ce code liste les classeurs dans un dossier, puis découpe leurs noms pour remplir une BDD.
Est il possible de ne pas lancer cette macro lorsque le nombre de dossier contenu est égal au nombre en mémoire du tableau qui est dans la cellule AB1 ou Cells(1, 28) car cette Macro prends un certain temps.
D'avance merci.
Dominique
1) - J'ai un probleme avec un classeur, voir la copie d'écran, ce classeur fonctionne sans probleme sur d'autres machines. Pourquoi ?
2) - J'ai le code qui suit (celui qui me pose probleme) ce code liste les classeurs dans un dossier, puis découpe leurs noms pour remplir une BDD.
Code:
Sub ListeTablo()
Dim DLig As Long, FolderFiles() As Variant
Dim Tmp As String, fCount As Long
Dim Ind
Dim sPath As String
' Désinhiber certaines fonctions d'Excel
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
With Sheets("Choix")
.Activate
DLig = .Range("R" & Rows.Count).End(xlUp).Row
If DLig >= 2 Then
.Range("A2:T" & DLig).ClearContents
End If
.Rows("1:1").AutoFilter Field:=17, Criteria1:="="
End With
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
MiseEnPlaceColonnes
' Initialisation
sPath = ThisWorkbook.Path & "\Fiche MP\"
fCount = 0
Tmp = Dir(sPath & "*.*")
While Tmp <> Empty
fCount = fCount + 1
ReDim Preserve FolderFiles(1 To fCount)
FolderFiles(fCount) = Tmp
Tmp = Dir
Wend
' Transposer le tableau dans la colonne R
Dim L&, C&, TSpl
ReDim Trésu(1 To fCount, 1 To 19)
For L = 1 To fCount
TSpl = Split(Replace(FolderFiles(L), ".xls", "________"), "_")
For C = 1 To 19: Trésu(L, C) = TSpl(C): Next C
Trésu(L, 18) = FolderFiles(L)
Trésu(L, 19) = "Fiche " & L
Next L
Cells(2, 1).Resize(fCount, 19).Value = Trésu
Cells(1, 28).Value = L - 1 'Le Nombre de Fichier en AB1
Remiseazero
' Inhiber certaines fonctions d'Excel
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Cells.Sort Key1:=Range("R1"), Order1:=xlDescending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("T1").Select
MsgBox "La Base est à jour !" & Chr$(13) & Chr$(13) & "Avec " & Cells(1, 28).Value & " fiches de Maintenance"
End Sub
D'avance merci.
Dominique