macro excel pour récupérer cellules

macro excel pour récupérer cellules - VB/VBA/VBS - Programmation

Marsh Posté le 12-05-2006 à 18:20:09    

Bonjour à tous,
 
Je dispose de 200 fichiers excel dans un répertoire.
Je voudrai faire la chose suivante que je suis incapable d'écrire en vba...
 
Récupérer dans chacun de ces fichiers les cellules A10 D10 H10 J10 D54 H54.
une fois ces cellules récupérées, je voudrai placer dans une feuille et dans un classeur à part les noms des fichiers avec à côté ces cellules.
Tout ceci afin d'avoir une vision globale de tous les fichiers avec les données qu'ils comportent dans ces cellules (A10 D10 H10 J10 D54 H54).
Afin de m'éviter d'ouvrir chaque fichier, puis faire 200 copier coller * le nombre de cellule..
 
Merci à tous pour votre aide

Reply

Marsh Posté le 12-05-2006 à 18:20:09   

Reply

Marsh Posté le 12-05-2006 à 18:54:30    

Une réponse parcellaire pour lire les noms de fichiers dans un dossier est donnée dans http://forum.hardware.fr/hardwaref [...] 9918-1.htm
 
Ensuite en utilisant le macro recorder outils/macro/nouvelle macro exécute la manip avec le premier fichier, cela te donneras un aperçu du code qu'il te faudra  
optimiser à la main puis adapter pour les autres fichiers


Message édité par kiki29 le 13-05-2006 à 13:50:52
Reply

Marsh Posté le 13-05-2006 à 13:51:41    

Ma BA : j'ai fait rapidement un fichier Lecture.xls qui fait à priori ce que tu demandes  
           pour 3 fichiers bidons ClasseurX.xls placés dans un dossier c:\Transfert  
           
Ma 2eme BA je viens de l'expérimenter avec qqs 200 fichiers : ça marche sans problemes mais il faut se montrer patient quant au temps de traitement ( 4 mn sur ma brouette )
La seule modif sera à faire dans  
Const CheminFichiers As String = "C:\Transfert\Essais\" pour donner le chemin de ton dossier qui pourra contenir n fichiers  
 
Puis toujours dans l'environnement VBA : Outils/Références cocher Microsoft Scripting Runtime
 
il ne te reste qu'à prendre contact en MP pour que je te zippe le fichier


Message édité par kiki29 le 13-01-2007 à 06:39:38
Reply

Marsh Posté le 13-05-2006 à 18:09:12    

Bonjour,  
 
  Si ce que Kiki29 t' as proposé plus haut ne te convient pas, voici un petit code :  
 
Workbooks.Open Filename:="C:\X\X\X\Classeur2.xls"   'Ouvre le preier classeur
Workbooks.Open Filename:="C:\X\X\X\Classeur3.xls"  'Ouvre le deuxième classeur
 
 
For i = 2 To Workbooks.Count  'Compte le nombre de classeur ouvert exepté celui actif.
ComboBox1.AddItem Workbooks(i).Name & " Correspondent les valeurs : " & Workbooks(i).Sheets(1).Range("A1" ) 'Insert dans la liste1 du classeur actif (celui à partir duquel et lancée la macro) le nom puis le valeur de la cellule A1 correspondant au des classeur ouvert précédement
Next i  'fin de boucle
 
PGreg

Reply

Marsh Posté le 14-05-2006 à 22:16:23    

Salut,  
 
  Le plus dur sera d' ouvrir tes 200 fichiers. Si je ne me trompe pas, il existe sous excel des fonctions permettant de faire un lien entre deux cellule de deux fichier sans falloir pour autant que les deux fichier soit ouvert.

Reply

Marsh Posté le 15-05-2006 à 10:31:31    

Il n'est pas question d'ouvrir 200 fichiers en même temps mais de les lire à la file
et cela ne pose absolument aucun probleme hormis que la variable qui me sert à décompter ce nombre de fichiers contenus dans le dossier est déclarée comme Integer
 
La copie se fait par valeur cela evite tous les problemes de liens brisés et autres


Message édité par kiki29 le 15-05-2006 à 17:45:51
Reply

Marsh Posté le 15-05-2006 à 17:09:15    

> PGreg  
     Tu m'as titillé les neurones car effectivement cela m'a rappellé qqch, en cherchant  
     cette fonction est à construire en utilisant ExecuteExcel4Macro
 
     mais le gain de performance est effrayant : 2.5 s pour traiter 200 fichiers soit un  
     gain de 100 ( Cela s'explique car AV activé sur ouverture Docs Office )


Message édité par kiki29 le 05-10-2006 à 10:00:15
Reply

Marsh Posté le 15-05-2006 à 21:13:49    

En espérant ne rien avoir oublié
Remise à jour du 09 Août 2007

'=========================================================================================================
' Créer un classeur avec une feuille vierge que l'on nommera
'     Import ( Nom sans importance )    : propriété Name sous VBE
'     ShImport                          : propriété (Name) sous VBE
'
' Dans environnement VBE
'       Recopier l'ensemble du code ci dessous dans un module
'       Outils | Références Cocher Microsoft Scripting Runtime
'
' Un bouton est à créer sur la feuille "Import"
'    il faut le nommer btnImport et lui affecter la procédure btnImport_QuandClic
'
' Const Dossier As String = "C:\Transfert\Essais" à modifier pour pointer sur le dossier désiré
'
'=========================================================================================================
Option Explicit
Dim NbFichiers As Integer
 
'   Dossier des classeurs à traiter
Const Dossier As String = "C:\Transfert\Essais"
'   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 = "Feuil1"
 
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"
 
        'A10 D10 H10 J10 D54 H54
        .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(NomDossierSource 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(NomDossierSource)
     
    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
 
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, "A10" )
                .Cells(NumeroLigne, 5) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "D10" )
                .Cells(NumeroLigne, 6) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "H10" )
                .Cells(NumeroLigne, 7) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "J10" )
                .Cells(NumeroLigne, 8) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "D54" )
                .Cells(NumeroLigne, 9) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "H54" )
 
                '  Si Dates à extraire mal formatées
                '  DDate = ExtraireValeur(DossierOk , NomFichier, NomFeuille, "Cxy" )
                '  If IsDate(DDate) Then .Cells(NumeroLigne, z) = Format(DDate, "dd/mm/yyyy" )
                 
                '  Sinon
                '  .Cells(NumeroLigne, z) = Format(DDate, "dd/mm/yyyy" )
 
            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
 
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


 
Pour Scripting Runtime http://www.microsoft.com/downloads [...] laylang=en
 
Sinon sans scripting Runtime
Remplacer ListeFichiersDans par celle ci : plus d'infos sur les dates de création et modif des fichiers.


Sub ListeFichiersDans(ByVal NomDossierSource As String)
Dim NomFichier As String
Dim Tableau() As String
Dim r As Long, i As Long
 
    NomFichier = Dir(NomDossierSource)
    Erase Tableau
    NbFichiers = 0
    Do While Len(NomFichier) > 0
        NbFichiers = NbFichiers + 1
        ReDim Preserve Tableau(1 To NbFichiers)
        Tableau(NbFichiers) = NomFichier
        NomFichier = Dir()
    Loop
     
    r = Range("A65536" ).End(xlUp).Row + 1
    If NbFichiers > 0 Then
        For i = 1 To UBound(Tableau)
            Cells(r, 1) = Tableau(i)
            r = r + 1
        Next
    End If
End Sub


Message édité par kiki29 le 10-04-2008 à 08:09:50
Reply

Marsh Posté le 19-05-2006 à 01:06:07    

Bonjour,
 
  Il suffit d' intégrer la structure ci dessous à ton code, il renvoie à une valeur d' une cellule d' un fichier. La mise à jour ce fait sans que le classeur contenant la donnée soit ouvert :  
 ='C:\X\X\X\[Classerutest.xls]Feuil1'!$A$1  'Mais à jour la valeur A1 du classeur test dans la cellule contenant cette structure.
 
On traduit par le code :  
 
Workbooks("Classeur2" ).Sheets(1).Range("A1" ).Copy
Workbooks("Classeur1" ).Activate
ActiveSheet.Paste link:=True  'Lien actif
 
 
 
 

Reply

Marsh Posté le 29-06-2006 à 10:35:36    

bonjour,
 
J'aimerais extraire des données d'un fichier sans l'ouvrir. J'ai adapté les différents morceaux de code figurant ici et j'arrive à avoir ce que je veux... pour des classeurs .xls. Mon problème est que je dois utilisé des .csv dont les séparateurs sont des , et non pas des ; qui est le séparateur par défaut reconnu par excel. Quelqu'un sait comment faire?

Reply

Marsh Posté le 29-06-2006 à 10:35:36   

Reply

Marsh Posté le 29-06-2006 à 10:51:00    

utilise ce topic ci, en modifiant le "" et "." par ton ";" et ","
http://forum.hardware.fr/hardwaref [...] 2905-1.htm

Reply

Marsh Posté le 29-06-2006 à 11:04:23    

je vois pas vraiment comment utiliser ca.
En fait mon csv, si je l'ouvre en double cliquant avec excel j'ai:
 
a1,,b1,c1,,d1
a2,,b2,c2,,d2
 
...
 
Ce que je voudrais à la fin c'est:
a1;c1
a2;c2
 
...
 
Ce que je fais pour l'instant c'est que j'ouvre les csv avec opentxt; mais ca prend énormément de temps (près de 10s à l'ouverture de chaque csv) et comme j'ai bcp de fichiers... Donc je voudrais réduire ce temps le plus possible, c'est pour ca que je pensais essayer de récupérer mes données sans ouvrir ce csv.

Reply

Marsh Posté le 29-06-2006 à 11:08:31    

j'ai résolu ce pb chez moi une fois. Applique la macro en question en remplacant cette fois  ",," par ";" puis ouvre ton fichier sous excel.

Reply

Marsh Posté le 29-06-2006 à 11:19:21    

bah ",," ca veut juste dire qu'il y a une case vide, c'etait qu'un exemple, c'est pas vraiment ca le problème. Mon problème c'est de ne pas ouvrir les csv (ce que je sais faire) et d'éviter les étapes intermédiaires. Mais c'est peut etre impossible.

Reply

Marsh Posté le 29-06-2006 à 11:28:00    

ton objectif n'est-il pas de "convertir" les fichiers csv en fichier xls ?

Reply

Marsh Posté le 29-06-2006 à 11:36:00    

non, ca je sais le faire. Du moins je sais ouvrir les csv comme si c'était des xls, quelque soit le séparateur. Mon problème est de récupéré RAPIDEMMENT (c'est fondamental, la vitesse est vraimetn le facteur critique ici) les données qui m'interessent. Or si j'ouvre ces csv (avec la méthode opentext et les paramètres qui vont bien), c'est très long.

Reply

Marsh Posté le 29-06-2006 à 11:38:53    

je pense que je vais essayer avec la formule de la haut (extraire une donnée sans ouvrir le fichier, combiné avec un truc bourrin du type: combinaison de "stxt", "gauche", et "trouve" pour extraire les données de ma chaine de caractère. Après avec la fonction "remplacer", je change le . (séparateur décimal) en , et voila. J'espère que ca marchera mieux question performance.

Reply

Marsh Posté le 29-06-2006 à 11:41:27    

je peux pas faire plus alors.

Reply

Marsh Posté le 29-06-2006 à 12:27:49    

A priori là haut ça n'est fait que pour lire des fichier XLS fermés
et les fichiers CSV étant des fichiers textes il faut utiliser qqch comme
 
Open "FICHTEST" For Input As #1    
Do While Not EOF(1)    
    Line Input #1, TextLine      
    .... traitement
Loop
Close #1  

Reply

Marsh Posté le 30-06-2006 à 12:11:35    

dans la solution que tu proposes, tu ouvres les fichiers, c'est bien ca?
et si je comprends bien tu les ouvres en fichier texte, donc non formaté, donc si je veux recupérer que les colonnes 1 et 3, par exemple, ou faire des tests sur les valeurs d'une colonne (du type index/equiv), je peux pas. C'est bien ca?

Reply

Marsh Posté le 01-07-2006 à 01:43:10    

Les fichiers CSV sont des fichiers Texte, tu les lis séquentiellement  
à la ligne traitement .......
un Split avec ; comme parametre te permet d'accéder aux données via les indices d'un Tableau à base 0 : Voir l'aide en ligne pour  Split
puis ensuite tu effectes cells(i,j)=la valeur du Tableau avec un indice 0
une autre avec Tableau(2)
 
ou alors import données externes puis suivre l'assistant
 
ou via macro recorder après import ( glisser icone *.csv sur Excel.exe ) et examen du code
quand on détruit des colonnes


Message édité par kiki29 le 01-07-2006 à 03:56:44
Reply

Marsh Posté le 01-07-2006 à 13:52:22    

non, mais je sais ouvrir les csv comme il faut pour que ca marche. Le probleme est que je voudrais me passer de l'ouverture des csv, parce qu'a chaque fois que j'en ouvre un, excel recalcule je ne sais quoi pdt plusieurs secondes (et je suis en calcul manuel). Et plusieurs secondes * 50 000 à la fin, ca fait long. Ou alors, il faudrait que j'arrive à annuler ce "recalcul".

Reply

Marsh Posté le 01-07-2006 à 15:20:37    

Placer dans une Procedure nommée Auto_Open  
Application.Calculation = xlManual

Reply

Marsh Posté le 02-07-2006 à 01:29:12    

dans ton idée cette procédure va dans le csv,c'est bien ca? (dsl, je débute en vba...). Dans ce cas, ca ne résoudrait toujours pas mon problème puisqu'avec 50000csv, tu comprends bien que je ne peux pas placer des macros dans tous.. Le classeur contenant les macros de traitement qui ouvrent les csv est en calcul manuel est application.calculatoin=xlManual précède l'instruction workbooks.opentxt.....

Reply

Marsh Posté le 01-08-2007 à 17:48:49    

Bonjour à tous.
 
Je voulais remercier kiki29 qui m'a permis de bien avancer sur mon travail.
 
Ces lignes de codes mon fait gagner un temps fou.
 
Mais j'ai problème que je n'arrive pas à résoudre...  :??:  
 
En effet, je fait bien tout ce que tu nous demande, c'est à dire cocher Microsoft Scripting Runtime, renommer la feuille dans VBA, la création du boutton sur la feuille Import, renommer la destination du fichier de pointage.
 
Mais malheureusement, lorsque je lance le code, il alimente la feuille Import mais ne fait apparaitre que le nom des fichiers et n'alimente pas les cellules que je souhaite.
 
Je ne sais plus quoi faire car j'ai essayé de retourner le problème dans tout les sens mais je ne trouve pas!
 
Merci de votre aide à tous.
 

Reply

Marsh Posté le 15-04-2008 à 09:47:12    

Bonjour à tous. Tout d'abord un grand merci aux membres actifs de ce forum qui m'a beaucoup aidé.
 
Le code que kiki29 a présenté correspond parfaitement au cas que je traite actuellement. Je l'ai adapté pour moi et ça marche parfaitement.
 
Cependant !
Je n'ai pas un dossier fixe regroupant tous les fichiers Excel, mais un dossier fixe <Montre> comprenant des dizaines de sous dossiers <Famille de montre>.  C'est dans ces sous dossiers que se trouvent les fichiers Excel qui m'intéressent (870 fichiers trouvés avec une macro Application.FileSearch)   La déclaration d'une constante de type <Const Dossier As String = "C:\Transfert\Essais"> ne semble donc pas adapté à mon cas car il faudrait la rendre variable :S
 
Je ne suis que novice en programmation. Après divers essais non concluants de modification du code pour aller fouiller dans chacun des sous dossier et faire exactement la même chose que le script initial, je reviens vers vous en espérant trouver un script adapté à mon souci.
 
Merci par avance à ceux qui me consacreront du temps !

Reply

Marsh Posté le 15-04-2008 à 10:36:02    

Salut, une version allégée mais avec la recherche recursive dans les sous dossiers à partir d'un dossier racine
http://cjoint.com/?epkIhFIoQU , à toi de l'adapter à ton contexte

Reply

Marsh Posté le 15-04-2008 à 10:42:03    

La version Texte


'==================================================================================
'
'   Dans environnement VBA
'   Outils | Références COCHER Microsoft Scripting Runtime
'
'   Sinon VBScript téléchargeable à
'   http://msdn.microsoft.com/library/default.asp?url=/downloads/list/webdev.asp
'
'==================================================================================
 
Option Explicit
 
Dim NbFichiers As Long
Dim DossierOk As String
 
'===============================================================================================
'   NomFichierRch   :   Fichier recherché, "*" si on les veut tous, "NCR*" si l'on ne veut que
'                       les fichiers débutant par NCR, voir aide en ligne sur opérateur LIKE
'                       ATTENTION sensible à la casse : minuscules/majuscules
'                       par exemple Classeur ‡ classeur
'
'   DossierRacine   :   "C:\...\Tst" dossier de départ pour la recherche des fichiers
'                       Dans Procédure btnImport_QuandClic modifer
'                           ListeFichiersDansDossier DossierOk, True
'                           en ListeFichiersDansDossier DossierOk, False
'                           si l'on ne veut pas de recherche dans les sous dossiers
'
'   NomFeuille      :   Si l'onglet des fichiers testés ne s'appelle pas "Feuil1"
'                       une erreur #REF! est incrite dans les cellules concernées
'                       de la feuille ShImport
'
'===============================================================================================
'
'Const NomFichierRch = "Classeur*.xls"
'Const NomFichierRch = "FF+COXX060#X*.xls"
'Const NomFichierRch = "####_#######_###_P*.xls"
 
Const NomFichierRch = "Classeur*.xls"
Const DossierRacine As String = "C:\Faq\FaqVba\Exemples"
Const NomFeuille As String = "Feuil1"
 
'===============================================================================================
'               Ici l'on ne traite q'une valeur située en A1
'               Pour infos j'ai ajouté une autre cellule Z3
'               Donc si l'on doit ajouter d'autres cellules à lire il
'               faudra aller modifier les procedures et fonctions suivantes
'                   Entete
'                   ListeFichiersDansDossier
'                   btnImport_QuandClic
'
'===============================================================================================
 
Private Sub Entete()
    With ShImport
        .Cells.Clear
        .Range("A3" )= "Fichier"
        .Range("B3" )= "Dossier"
        .Range("C3" )= "Date Création"
        .Range("D3" )= "Taille"
 
        '   A1  Z3
        .Range("E3" )= "A1"
        '.Range("E4" )= "Z3"
    End With
End Sub
 
Private Sub ListeFichiersDansDossier(ByVal NomDossierSource As String, ByVal InclureSousDossiers As Boolean)
Dim FSO As Scripting.FileSystemObject
Dim DossierSource As Scripting.Folder, SousDossier As Scripting.Folder
Dim Fichier As Scripting.File
Dim Extension As String
Dim r As Long, VerifNom As Boolean
 
    Set FSO = New Scripting.FileSystemObject
    Set DossierSource = FSO.GetFolder(NomDossierSource)
 
    r = ShImport.Range("A65536" ).End(xlUp).Row + 1
 
    For Each Fichier In DossierSource.Files
        VerifNom = UCase(Fichier.Name) Like UCase(NomFichierRch)
        If VerifNom Then
            With ShImport
                .Cells(r, 1)= Fichier.Name
                .Cells(r, 2)= Fichier.ParentFolder
                .Cells(r, 3)= Fichier.DateCreated
                .Cells(r, 4)= Fichier.Size
                NbFichiers = NbFichiers + 1
                r = r + 1
            End With
            Application.StatusBar = "Lecture noms : " & r
        End If
    Next Fichier
 
    If InclureSousDossiers Then
        For Each SousDossier In DossierSource.SubFolders
            ListeFichiersDansDossier SousDossier.Path, True
        Next SousDossier
        Set SousDossier = Nothing
    End If
 
    ActiveWorkbook.Names.Add Name:="Zone_de_Tri", RefersToR1C1:="=Import!R4C1:R" & (NbFichiers + 3) & "C5"
    ' Si cellule Z3 remplacer la ligne ci-dessus par
    'ActiveWorkbook.Names.Add Name:="Zone_de_Tri", RefersToR1C1:="=Import!R4C1:R" & (NbFichiers + 3) & "C6"
 
    Set DossierSource = Nothing
    Set FSO = Nothing
 
End Sub
 
Private Function ExtraireValeur(ByVal Dossier As String, ByVal Fichier As String, _
                                ByVal Feuille As String, ByVal Cellule As String)
Dim Argument As String
    Dossier = Replace(Dossier, "'", "''" )
    Fichier = Replace(Fichier, "'", "''" )
    Feuille = Replace(Feuille, "'", "''" )
    Argument = "'" & Dossier & "[" & Fichier & "]" & Feuille & "'!" & Range(Cellule).Address(, , xlR1C1)
    ExtraireValeur = ExecuteExcel4Macro(Argument)
End Function
 
Private Sub btnImport_QuandClic()
Dim Debut As Variant
Dim NumeroLigne As Long, i As Long
Dim NomFichier As String
Dim NomDossier As String
 
    Debut = Time()
    Application.ScreenUpdating = False
    NbFichiers = 0
    NumeroLigne = 4
 
    Entete
    DossierOk = BackSlashDossier(DossierRacine)
 
    '   Recherche récursive ou non à partir de DossierRacine
    '   si recherche dans DossierRacine seulement
    '   remplacer ListeFichiersDansDossier DossierOk, True par
    '   ListeFichiersDansDossier DossierOk, False
 
    ListeFichiersDansDossier DossierOk, True
 
    For i = 1 To NbFichiers
        NomFichier = ShImport.Range("A" & NumeroLigne)
        NomDossier = BackSlashDossier(ShImport.Range("B" & NumeroLigne))
 
        With ShImport
            .Cells(NumeroLigne, 5) = ExtraireValeur(NomDossier, NomFichier, NomFeuille, "A1" )
            '.Cells(NumeroLigne, 6) = ExtraireValeur(NomDossier, NomFichier, NomFeuille, "Z3" )
        End With
        NumeroLigne = NumeroLigne + 1
        Application.StatusBar = i & " / " & NbFichiers
    Next
 
    Application.StatusBar = "Terminé : " & Format((Time() - Debut) * 100000, "0.00" )
 
    MepFinale
 
    Application.ScreenUpdating = True
End Sub
 
Private Function BackSlashDossier(ByVal TstDossier As String) As String
    If Right(TstDossier, 1) <> "\" Then TstDossier = TstDossier & "\"
    BackSlashDossier = TstDossier
End Function
 
Private Sub MepFinale()
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
 
    Rows("3:3" ).Font.Bold = True
    Columns("C:D" ).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    Columns("A:E" ).Columns.AutoFit
    DispoBoutons
    Range("A1" ).Select
End Sub
 
Public 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 Tri()
    Application.Goto Reference:="Zone_de_Tri"
    Selection.Sort Key1:=Range("A4" ), Order1:=xlAscending, Header:=xlNo
    Range("A1" ).Select
End Sub

Message cité 1 fois
Message édité par kiki29 le 28-08-2008 à 15:24:00
Reply

Marsh Posté le 16-04-2008 à 09:59:42    

Bonjour a tous,
 
je suis entrain de chercher le moyen avec VBA d automatiser une tache. J’avoue que je suis encore débutant et je sollicite votre aide.  
 
J'ai une Base de  Excel qui fais 3 feuilles, bien sure que les 3 se ressemblent avec les même colonnes, les colonnes qui m intéressent c’est : Dates, Noms et Notes, => j’ai des notes pour des noms tout les moins depuis 2004, cela veut dire que les noms se répètent les dates aussi mais les notes non.=> les nom doivent être filtré pour donner lieu a un vecteur NOM, les dates c’est pareil, pour attribuer des notes en fonction du nom et la date dans un tableau :
Et je voudrai faire un tableau ou il y a des notes en fonction du nom (en ligne) et de la date (en colonne), il me cherche la note et quand il n’y a pas de note entre deux dates, il me recopie la note de la date précédente ( ex j ai une note x pour le nom A le 31/01/05 et pas de31/02/05, puis j’ai une note y  le 31/03/05.mon tableau aura l allure suivante:
 
Merci d'avance pour vos conseils
 
 31/01/05 31/02/05 31/03/05
l'indiv A x x y
l'indiv B    
 

Reply

Marsh Posté le 25-06-2009 à 12:58:55    

kiki29 a écrit :



...
Const DossierRacine As String = "C:\Faq\FaqVba\Exemples"
...



 
UP
 
 :hello:  
 
Dans l'extrait du code cité plus haut, comment faire pour que le chemin corresponde à celui du fichier à partir duquel on lance la procédure ?
En effet, j'ai insérer cette procédure dans un de mes fichiers et il tourne parfaitement (reste plus qu'à l'adapter au résultat que je souhaite).
Le souci c'est que mes fichiers vont être sur un serveur réseau et que la lettre du lecteur va changer...
Dans l'exemple, c'est le "C" qui change... par U, V, M...
 
;)


---------------
iMac 4Ghz (fin 2015) RAM 16Go SSD 256Go SSD 2To
Reply

Marsh Posté le 25-06-2009 à 22:32:32    

Salut,

Sub SelDossier()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Sélectionner le Dossier Racine"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            DoEvents
            Import .SelectedItems(1)
        End If
    End With
End Sub


en modifiant btnImport_QuandClic en conséquence


Message édité par kiki29 le 05-07-2009 à 05:07:23
Reply

Marsh Posté le 02-03-2010 à 22:41:20    

Bonjour,
 
Je vous contacte suite à l'un de vos messages posté en 2006 !!
Ce code (ci-dessous) m'a été très utile et je vous en remercie mais après m'être torturer l'esprit depuis 3 jours pour y appliquer une modification sans succès, je me tourne vers vous car je ne trouve pas de réponse sur le net.
 
Tout d'abord je vous explique l'utilité de votre code dans mon cas.
Tous les matins je reçoit des rapports en .CSV dont les noms des fichiers sont STEPAGIRA et la date du jour : STEPAGIRA010310, STEPAGIRA020310...
Comme ce sont des fichiers CSV, il n'y a qu'une feuille mais le nom de la feuille n'est pas Feuill1 mais une recopie du nom du fichier.
Je peux me débrouiller pour transformer les fichiers .CSV en fichiers .XSL mais le nom de la feuille reste identique au .CSV
 
Voici mes questions :
 
1/ Comment faire pour que la recopie n'ouvre que les fichiers en .XSL car dans votre code cela ouvre tous les fichiers du dossier (ici "C:\Transfert\Essais" )
 
2/ Je voudrais recopier la seule feuille qu'il y a dans le fichier (peut importe son nom) et nom la feuille nommée Feuil1
Dans votre code c'est Const NomFeuille As String = "Feuil1"
 
Je vous remercie par avance si vous avez la solution
 
Cordialement
 
 
 
=========================================================================================================
' Créer un classeur avec une feuille vierge que l'on nommera
'     Import ( Nom sans importance )    : propriété Name sous VBE
'     ShImport                          : propriété (Name) sous VBE
'
' Dans environnement VBE
'       Recopier l'ensemble du code ci dessous dans un module
'       Outils | Références Cocher Microsoft Scripting Runtime
'
' Un bouton est à créer sur la feuille "Import"
'    il faut le nommer btnImport et lui affecter la procédure btnImport_QuandClic
'
' Const Dossier As String = "C:\Transfert\Essais" à modifier pour pointer sur le dossier désiré
'
'=========================================================================================================
Option Explicit
Dim NbFichiers As Integer
 
'   Dossier des classeurs à traiter
Const Dossier As String = "C:\Transfert\Essais"
'   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 = "Feuil1"
 
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"
 
        'A10 D10 H10 J10 D54 H54
        .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(NomDossierSource 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(NomDossierSource)
     
    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
 
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, "A10" )
                .Cells(NumeroLigne, 5) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "D10" )
                .Cells(NumeroLigne, 6) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "H10" )
                .Cells(NumeroLigne, 7) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "J10" )
                .Cells(NumeroLigne, 8) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "D54" )
                .Cells(NumeroLigne, 9) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "H54" )
 
                '  Si Dates à extraire mal formatées
                '  DDate = ExtraireValeur(DossierOk , NomFichier, NomFeuille, "Cxy" )
                '  If IsDate(DDate) Then .Cells(NumeroLigne, z) = Format(DDate, "dd/mm/yyyy" )
                 
                '  Sinon
                '  .Cells(NumeroLigne, z) = Format(DDate, "dd/mm/yyyy" )
 
            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
 
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
[/fixed]
 
Pour Scripting Runtime http://www.microsoft.com/downloads [...] laylang=en
 
Sinon sans scripting Runtime
Remplacer ListeFichiersDans par celle ci : plus d'infos sur les dates de création et modif des fichiers.


Sub ListeFichiersDans(ByVal NomDossierSource As String)
Dim NomFichier As String
Dim Tableau() As String
Dim r As Long, i As Long
 
    NomFichier = Dir(NomDossierSource)
    Erase Tableau
    NbFichiers = 0
    Do While Len(NomFichier) > 0
        NbFichiers = NbFichiers + 1
        ReDim Preserve Tableau(1 To NbFichiers)
        Tableau(NbFichiers) = NomFichier
        NomFichier = Dir()
    Loop
     
    r = Range("A65536" ).End(xlUp).Row + 1
    If NbFichiers > 0 Then
        For i = 1 To UBound(Tableau)
            Cells(r, 1) = Tableau(i)
            r = r + 1
        Next
    End If
End Sub

[/quotemsg]

Reply

Marsh Posté le 04-03-2010 à 18:40:00    

Salut, vite fait , à adapter à ton contexte


Option Explicit
.....
Dim NomFeuille As String
Const TypeFichier As String = "xls"
 
Dans procédure ListeFichiersDans
    .....
    For Each Fichier In DossierSource.Files
        If UCase(FSO.GetExtensionName(Fichier)) = UCase(TypeFichier) Then
  .....
        End If
    Next Fichier
    .....
 
Dans btnImport_QuandClic
    .....
    For i = 1 To NbFichiers
        NomFichier = ShImport.Range("A" & NumeroLigne)
        NomFeuille = Left$(ShImport.Range("A" & NumeroLigne), 15)
 .....
    Next i
    .....

Reply

Marsh Posté le 05-03-2010 à 12:25:04    

Merci pour votre aide,
 
Je vais essayer de me débrouiller avec ça.
 

Reply

Marsh Posté le 05-03-2010 à 17:33:37    

Salut, c'est juste une remarque mais la méthode de lecture pourrait être différente puisqu'il s'agit au départ de fichiers csv ( qui sont juste des fichiers textes ) et donc ne pas nécessiter de passage en XLS.Il faudrait seulement connaitre les coordonnées des données à lire dans ces fichiers CSV .Pour cela il faudrait qqs fichiers échantillons


Message édité par kiki29 le 05-03-2010 à 17:34:33
Reply

Marsh Posté le 07-03-2010 à 19:53:12    

Bonsoir,  
Je me suis encore arraché les cheveux sur ce code aujourd'hui en intégrant vos modifications mais sans succès donc je vous sollicite à nouveau.
J'ai laissé tomber le fait de passer mes fichiers csv en xls comme vous le préconisez.
Par contre j'ai toujours le même soucis, c'est à dire si le nom de la feuille n'est pas Feuil1 ça ne marche pas. (marche si tel est le cas par contre)
Etant débutant dans la programmation, je ne vois pas où ça bloque. Peut être parce que j'ai essayé d'intégrer les 2 modif que j'avais demander précédemment.
Je n'ai pas trouvé comment joindre des fichiers à mon message, si vous savez ?
Merci

Reply

Marsh Posté le 08-03-2010 à 04:57:09    

Salut, il faut passer par http://cjoint.com/ ou http://www.cijoint.fr/

Reply

Marsh Posté le 15-03-2010 à 19:36:57    

Merci pour votre aide, je ne suis pas revenu vers vous car j'ai fini par trouver la solution.

Reply

Marsh Posté le 20-07-2011 à 14:16:37    


Bonjour,  
Je vais réouvrir cette conversation. Je dois mettre en place un fichier de synthsé de plusieurs fichiers excel. Le code ci-dessus m'a bcp aidé (Merci KIKI29). Cependant j'ai un soucis: je voudrias savoir si il y a un moyen pour parcourir les feuilles d'un fichier fermé ( sans l' ouvrir), étant donné que mes fiches excel comportent plusiers feuilles à traiter.
Merci d'avance pour votre aide.

Reply

Marsh Posté le 20-07-2011 à 19:45:24    

Salut, un exemple à adapter qui retourne le nom des feuilles d'un classeur
ShDatas étant le CodeName de la feuille recevant ici les noms des feuilles du fichier passé dans sNom
de la procédure ListeNomFeuilles
Affecter un bouton à SelFichier


'   Références  Microsoft ADO Ext. 2.8 for DLL and Security
'               Microsoft ActiveX Data Objects 2.x Library
 
Option Explicit
 
Sub SelFichier()
Dim Fichier As Variant
 
    ChDir ThisWorkbook.Path
 
    Fichier = Application.GetOpenFilename("Fichier xls (*.xls), *.xls" )
    If Fichier <> False Then
        Application.ScreenUpdating = False
        ListeNomFeuilles (Fichier)
        Application.ScreenUpdating = True
    End If
End Sub
 
Private Sub ListeNomFeuilles(sNom As String)
Dim Conn As Object
Dim Cat As Object
Dim FeuilleXL As Object
Dim iRow As Long
 
    ShDatas.Cells.Clear
    Set Conn = CreateObject("ADODB.Connection" )
    Set Cat = CreateObject("ADOX.Catalog" )
 
    Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & sNom & ";Extended Properties=Excel 8.0;"
 
    Set Cat.ActiveConnection = Conn
 
    iRow = 1
    For Each FeuilleXL In Cat.Tables
        Select Case Right$(FeuilleXL.Name, 1)
            Case "$"
                ShDatas.Cells(iRow, 1) = Left$(FeuilleXL.Name, Len(FeuilleXL.Name) - 1)
                iRow = iRow + 1
            Case "'"
                ' Nom de feuille comportant des espaces
                ShDatas.Cells(iRow, 1) = Mid$(FeuilleXL.Name, 2, Len(FeuilleXL.Name) - 3)
                iRow = iRow + 1
        End Select
    Next FeuilleXL
 
    Conn.Close
    Set Conn = Nothing
    Set Cat = Nothing
End Sub


Message édité par kiki29 le 20-07-2011 à 22:30:44

---------------
Myanmar 90/91 : http://gadaud.gerard.free.fr/publi [...] index.html
Reply

Marsh Posté le    

Reply

Sujets relatifs:

Leave a Replay

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