marouma | Bonjour,
J'ai utilisé cette macro pour pouvoir pointer vers un dossier et récupérer certaines données d'un seul onglet("General" ).
Mais je n'arrive pas à la faire fonctionner!!
quand je lance l’exécution, rien ne se passe
Merci bcp pour votre aide Code :
- Private Sub CommandButton1_Click()
- End Sub
- Sub btnImport_QuandClic()
- Dim Debut As Variant
- Dim NumeroLigne As Integer, i As Integer
- Dim NomFichier As String
- Dim DDate As String
- Dim DossierOk As String
-
- ' Par curiosité
- Debut = Time()
- Application.ScreenUpdating = False
- Entete
- DossierOk = Dossier
- ' Pour éviter le drame du copier/coller ....
- If Right(DossierOk, 1) <> "\" Then DossierOk = DossierOk & "\"
-
- ListeFichiersDans DossierOk
-
- ' Si un onglet de NomFichier ne s'appelle pas NomFeuille
- ' une erreur #REF! est incrite dans les cellules concernées
-
- ' On démarre à cette ligne
- NumeroLigne = 4
- For i = 1 To NbFichiers
- NomFichier = ShImport.Range("A" & NumeroLigne)
-
- With ShImport
- .Cells(NumeroLigne, 4) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "A7" )
- .Cells(NumeroLigne, 5) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "D7" )
- .Cells(NumeroLigne, 6) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "H7" )
- .Cells(NumeroLigne, 7) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "J7" )
- .Cells(NumeroLigne, 8) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "D7" )
- .Cells(NumeroLigne, 9) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "H7" )
-
-
- End With
-
- NumeroLigne = NumeroLigne + 1
- Application.StatusBar = i & " / " & NbFichiers
- Next
-
- Application.StatusBar = "Terminé : " & Format((Time() - Debut) * 100000, "0.00" )
-
- ' Revenir en haut à gauche
- With ActiveWindow
- .ScrollRow = 1
- .ScrollColumn = 1
- End With
-
- With ShImport
- .Rows("3:3" ).Font.Bold = True
- .Columns("B:C" ).Select
- With Selection
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlBottom
- End With
- .Columns("A:I" ).Columns.AutoFit
- .Range("A1" ).Select
- End With
- Application.ScreenUpdating = True
- End Sub
- End Sub
- End Sub
- Private Sub UserForm_Click()
- Option Explicit
- Dim NbFichiers As Integer
- ' Dossier des classeurs à traiter
- Const Dossier As String = "C:\Documents and Settings\mkhalmadani\Bureau\Dossier"
- ' On suppose que tous les fichiers contiennent les données dans Feuil1
- ' Si un onglet ne s'appelle pas NomFeuille
- ' une erreur #REF! est inscrite dans les cellules concernées
- Const NomFeuille As String = "General"
-
- Private Sub Entete()
- With ShImport
- ' Tout effacer
- .Cells.Clear
- .Range("A3" ).Formula = "Fichier"
- ' A tout hasard cela peut être interessant
- ' d'avoir ces infos sur les fichiers
- .Range("B3" ) = "Date de Création"
- .Range("C3" ) = "Date Dernière Modification"
-
- 'test avec quelques cellules
-
- .Range("D3" ) = "A10"
- .Range("E3" ) = "D10"
- .Range("F3" ) = "H10"
- .Range("G3" ) = "J10"
- .Range("H3" ) = "D54"
- .Range("I3" ) = "H54"
- End With
- End Sub
-
- Private Sub ListeFichiersDans(Dossier As String)
- Dim FSO As Scripting.FileSystemObject
- Dim DossierSource As Scripting.Folder
- Dim Fichier As Scripting.file
- Dim r As Long
-
- Set FSO = New Scripting.FileSystemObject
- Set DossierSource = FSO.GetFolder(Dossier)
-
- NbFichiers = 0
- r = ShImport.Range("A65536" ).End(xlUp).Row + 1
-
- ' Balayer le dossier et extraire le nom des fichiers
- For Each Fichier In DossierSource.Files
- With ShImport
- .Cells(r, 1) = Fichier.Name
- .Cells(r, 2) = Fichier.DateCreated
- .Cells(r, 3) = Fichier.DateLastModified
- End With
- NbFichiers = NbFichiers + 1
- r = r + 1
- Next Fichier
-
- Set Fichier = Nothing
- Set DossierSource = Nothing
- Set FSO = Nothing
- End Sub
-
- ' Permet de lire une valeur dans un fichier Excel fermé
- Private Function ExtraireValeur(ByVal Dossier As String, ByVal Fichier As String, ByVal Feuille As String, ByVal Cellule As String)
- Dim Argument As String
- Fichier = Replace(Fichier, "'", "''" )
- Argument = "'" & Dossier & "[" & Fichier & "]" & Feuille & "'!" & Range(Cellule).Address(, , xlR1C1)
- ExtraireValeur = ExecuteExcel4Macro(Argument)
- End Function
- Private Sub DispoBoutons()
- Dim t As Range
- With ShImport
- .Activate
- .Rows(1).RowHeight = 12.75
- .Rows(2).RowHeight = 12.75
-
- Set t = .Cells(1, 3)
- With .Buttons("btnImport" )
- .Left = t.Left + 3
- .Top = t.Top + 5
- .Width = t.Width - 6
- .Height = Rows(1).RowHeight + Rows(2).RowHeight - 8
- End With
- End With
- End Sub
-
- Private Sub Workbook_Open()
- DispoBoutons
- With ActiveWindow
- .ScrollRow = 1
- .ScrollColumn = 1
- End With
- ShImport.Range("A1" ).Select
- End Sub
- End Sub
|
|