Forum |  HardWare.fr | News | Articles | PC | S'identifier | S'inscrire | Shop Recherche
2737 connectés 

  FORUM HardWare.fr
  Programmation
  VB/VBA/VBS

  fusion de pls fichiers xls

 
 


 Mot :   Pseudo :  
 
Bas de page
Auteur Sujet :

fusion de pls fichiers xls

n°2130573
marouma
Posté le 09-03-2012 à 11:44:36  profilanswer
 

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

mood
Publicité
Posté le 09-03-2012 à 11:44:36  profilanswer
 


Aller à :
Ajouter une réponse
  FORUM HardWare.fr
  Programmation
  VB/VBA/VBS

  fusion de pls fichiers xls

 

Sujets relatifs
Lecture de gros fichiers CSV sur AndroidSouci de fichiers introuvables
cherche logiciel de consultation de fichiers multiformatsErreur lors de la lecture de gros fichiers sur réseau local
[C] problème de fichiersEnvoi de fichiers dans la zone privée d'un site, confidentialité ?
copier toutes les feuilles d'un ensemble de fichiers ExcelLes fichiers en C
Fichiers de Localisation (Appli. Multi-Langues)fusion de fichiers
Plus de sujets relatifs à : fusion de pls fichiers xls

Forum MesDiscussions.Net, Version 2010.2
(c) 2000-2011 Doctissimo
Page générée en 0.085 secondes

Copyright © 1997-2025 Groupe LDLC (Signaler un contenu illicite / Données personnelles)