fusion de pls fichiers xls

fusion de pls fichiers xls - VB/VBA/VBS - Programmation

Marsh Posté le 09-03-2012 à 11:44:36    

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 :
  1. Private Sub CommandButton1_Click()
  2. End Sub
  3. Sub btnImport_QuandClic()
  4. Dim Debut As Variant
  5. Dim NumeroLigne As Integer, i As Integer
  6. Dim NomFichier As String
  7. Dim DDate As String
  8. Dim DossierOk As String
  9.  
  10.     ' Par curiosité
  11.     Debut = Time()
  12.     Application.ScreenUpdating = False
  13.         Entete
  14.         DossierOk = Dossier
  15.         ' Pour éviter le drame du copier/coller ....
  16.         If Right(DossierOk, 1) <> "\" Then DossierOk = DossierOk & "\"
  17.  
  18.         ListeFichiersDans DossierOk
  19.          
  20.         ' Si un onglet de NomFichier ne s'appelle pas NomFeuille
  21.         ' une erreur #REF! est incrite dans les cellules concernées
  22.          
  23.         ' On démarre à cette ligne
  24.         NumeroLigne = 4
  25.         For i = 1 To NbFichiers
  26.             NomFichier = ShImport.Range("A" & NumeroLigne)
  27.  
  28.             With ShImport
  29.                 .Cells(NumeroLigne, 4) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "A7" )
  30.                 .Cells(NumeroLigne, 5) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "D7" )
  31.                 .Cells(NumeroLigne, 6) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "H7" )
  32.                 .Cells(NumeroLigne, 7) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "J7" )
  33.                 .Cells(NumeroLigne, 8) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "D7" )
  34.                 .Cells(NumeroLigne, 9) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "H7" )
  35.  
  36.    
  37.             End With
  38.              
  39.             NumeroLigne = NumeroLigne + 1
  40.             Application.StatusBar = i & " / " & NbFichiers
  41.         Next
  42.          
  43.         Application.StatusBar = "Terminé : " & Format((Time() - Debut) * 100000, "0.00" )
  44.      
  45.         ' Revenir en haut à gauche
  46.         With ActiveWindow
  47.             .ScrollRow = 1
  48.             .ScrollColumn = 1
  49.         End With
  50.          
  51.        With ShImport
  52.            .Rows("3:3" ).Font.Bold = True
  53.            .Columns("B:C" ).Select
  54.            With Selection
  55.                 .HorizontalAlignment = xlCenter
  56.                 .VerticalAlignment = xlBottom
  57.            End With
  58.            .Columns("A:I" ).Columns.AutoFit
  59.            .Range("A1" ).Select
  60.       End With
  61.     Application.ScreenUpdating = True
  62. End Sub
  64. End Sub
  65. End Sub
  67. Private Sub UserForm_Click()
  70. Option Explicit
  71. Dim NbFichiers As Integer
  73. '   Dossier des classeurs à traiter
  74. Const Dossier As String = "C:\Documents and Settings\mkhalmadani\Bureau\Dossier"
  75. '   On suppose que tous les fichiers contiennent les données dans Feuil1
  76. '       Si un onglet ne s'appelle pas NomFeuille
  77. '       une erreur #REF! est inscrite dans les cellules concernées
  78. Const NomFeuille As String = "General"
  79.  
  80. Private Sub Entete()
  81.     With ShImport
  82.         ' Tout effacer
  83.         .Cells.Clear
  84.         .Range("A3" ).Formula = "Fichier"
  85.         ' A tout hasard cela peut être interessant
  86.         ' d'avoir ces infos sur les fichiers
  87.         .Range("B3" ) = "Date de Création"
  88.         .Range("C3" ) = "Date Dernière Modification"
  89.  
  90.         'test avec quelques cellules
  91.        
  92.         .Range("D3" ) = "A10"
  93.         .Range("E3" ) = "D10"
  94.         .Range("F3" ) = "H10"
  95.         .Range("G3" ) = "J10"
  96.         .Range("H3" ) = "D54"
  97.         .Range("I3" ) = "H54"
  98.     End With
  99. End Sub
  100.  
  101. Private Sub ListeFichiersDans(Dossier As String)
  102. Dim FSO As Scripting.FileSystemObject
  103. Dim DossierSource As Scripting.Folder
  104. Dim Fichier As Scripting.file
  105. Dim r As Long
  106.  
  107.     Set FSO = New Scripting.FileSystemObject
  108.     Set DossierSource = FSO.GetFolder(Dossier)
  109.      
  110.     NbFichiers = 0
  111.     r = ShImport.Range("A65536" ).End(xlUp).Row + 1
  112.      
  113.     ' Balayer le dossier et extraire le nom des fichiers
  114.     For Each Fichier In DossierSource.Files
  115.         With ShImport
  116.             .Cells(r, 1) = Fichier.Name
  117.             .Cells(r, 2) = Fichier.DateCreated
  118.             .Cells(r, 3) = Fichier.DateLastModified
  119.         End With
  120.         NbFichiers = NbFichiers + 1
  121.         r = r + 1
  122.     Next Fichier
  123.      
  124.     Set Fichier = Nothing
  125.     Set DossierSource = Nothing
  126.     Set FSO = Nothing
  127. End Sub
  128.  
  129. '   Permet de lire une valeur dans un fichier Excel fermé
  130. Private Function ExtraireValeur(ByVal Dossier As String, ByVal Fichier As String, ByVal Feuille As String, ByVal Cellule As String)
  131. Dim Argument As String
  132.     Fichier = Replace(Fichier, "'", "''" )
  133.     Argument = "'" & Dossier & "[" & Fichier & "]" & Feuille & "'!" & Range(Cellule).Address(, , xlR1C1)
  134.     ExtraireValeur = ExecuteExcel4Macro(Argument)
  135. End Function
  137. Private Sub DispoBoutons()
  138. Dim t As Range
  139.     With ShImport
  140.         .Activate
  141.         .Rows(1).RowHeight = 12.75
  142.         .Rows(2).RowHeight = 12.75
  143.          
  144.         Set t = .Cells(1, 3)
  145.         With .Buttons("btnImport" )
  146.             .Left = t.Left + 3
  147.             .Top = t.Top + 5
  148.             .Width = t.Width - 6
  149.             .Height = Rows(1).RowHeight + Rows(2).RowHeight - 8
  150.         End With
  151.     End With
  152. End Sub
  153.  
  154. Private Sub Workbook_Open()
  155.     DispoBoutons
  156.     With ActiveWindow
  157.         .ScrollRow = 1
  158.         .ScrollColumn = 1
  159.     End With
  160.     ShImport.Range("A1" ).Select
  161. End Sub
  163. End Sub

Reply

Marsh Posté le 09-03-2012 à 11:44:36   

Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed