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

  FORUM HardWare.fr
  Programmation
  VB/VBA/VBS

  Problème pour appelé une feuille & extraire des données sous excel

 


 Mot :   Pseudo :  
 
Bas de page
Auteur Sujet :

Problème pour appelé une feuille & extraire des données sous excel

n°2009213
@pierre
Posté le 15-07-2010 à 08:24:02  profilanswer
 

Bonjour à tous !
 
J'utilise cette super macro d'un ancien sujet :
http://forum.hardware.fr/hfr/Progr [...] m#t1717605
pour extraire les données de mes cellules et les répertoriés dans un fichier recapitulatif. La macro recherche recursivement tous les classeurs dans les dossier, et extrait les données de : "Feuil1"  
 
voici mon problème : mes fichiers excel n'ont qu'une unique feuille mais le nom n'est jamais Feuil1, du coup la macro renvoi #REF  pour toutes les cellules de ces classeurs. Existe il une solution pour que cette macro ne s'occupe plus du nom de la feuille mais choisi par exemple toujours la premiere feuille du classeur?  
 
Merci !

mood
Publicité
Posté le 15-07-2010 à 08:24:02  profilanswer
 

n°2009253
SuppotDeSa​Tante
Aka dje69r
Posté le 15-07-2010 à 11:57:04  profilanswer
 

Hello
 
Pour recuperer le nom de ta feuille tu peux remplacer ta constante par
Feuille = Sheets(1).Name  


---------------
Soyez malin, louez entre voisins !
n°2009264
@pierre
Posté le 15-07-2010 à 12:10:02  profilanswer
 

Oui je pense c'est une bonne idée, mais où le placer dans ma macro? car si je le met comme constante, il compile pas.Et je my connais peu en VBA...

n°2009269
@pierre
Posté le 15-07-2010 à 12:27:00  profilanswer
 

SuppotDeSaTante a écrit :

Hello
 
Pour recuperer le nom de ta feuille tu peux remplacer ta constante par
Feuille = Sheets(1).Name  


 
pour plus de précision voici comment est défini ma constante :
 

Code :
  1. Const NomFeuille As String = "Feuil1"


 
Voici la fonction principale :
 

Code :
  1. Private Sub btnImport_QuandClic()
  2. Dim Debut As Variant
  3. Dim NumeroLigne As Long, i As Long
  4. Dim NomFichier As String
  5. Dim NomDossier As String
  6.     Debut = Time()
  7.     Application.ScreenUpdating = False
  8.     NbFichiers = 0
  9.     NumeroLigne = 4
  10.     Entete
  11.     DossierOk = BackSlashDossier(DossierRacine)
  12.     '   Recherche récursive ou non à partir de DossierRacine
  13.     '   si recherche dans DossierRacine seulement
  14.     '   remplacer ListeFichiersDansDossier DossierOk, True par
  15.     '   ListeFichiersDansDossier DossierOk, False
  16.     ListeFichiersDansDossier DossierOk, True
  17.     For i = 1 To NbFichiers
  18.         NomFichier = ShImport.Range("A" & NumeroLigne)
  19.         NomDossier = BackSlashDossier(ShImport.Range("B" & NumeroLigne))
  20.         With ShImport
  21.             .Cells(NumeroLigne, 5) = ExtraireValeur(NomDossier, NomFichier, NomFeuille, "A1" )
  22.             '.Cells(NumeroLigne, 6) = ExtraireValeur(NomDossier, NomFichier, NomFeuille, "Z3" )
  23.         End With
  24.         NumeroLigne = NumeroLigne + 1
  25.         Application.StatusBar = i & " / " & NbFichiers
  26.     Next
  27.     Application.StatusBar = "Terminé : " & Format((Time() - Debut) * 100000, "0.00" )
  28.     MepFinale
  29.     Application.ScreenUpdating = True
  30. End Sub


et la fonction extraire valeur :

Code :
  1. Private Function ExtraireValeur(ByVal Dossier As String, ByVal Fichier As String, _
  2.                                 ByVal Feuille As String, ByVal Cellule As String)
  3. Dim Argument As String
  4.     Dossier = Replace(Dossier, "'", "''" )
  5.     Fichier = Replace(Fichier, "'", "''" )
  6.     Feuille = Replace(Feuille, "'", "''" )
  7.     Argument = "'" & Dossier & "[" & Fichier & "]" & Feuille & "'!" & Range(Cellule).Address(, , xlR1C1)
  8.     ExtraireValeur = ExecuteExcel4Macro(Argument)
  9. End Function


 

n°2009276
SuppotDeSa​Tante
Aka dje69r
Posté le 15-07-2010 à 13:03:28  profilanswer
 

J'avais ete sur le lien de kiki29 à la base.
 
Le code donné par kiki29 est a modifier bien entendu puisqu'il lit les valeur dans le fichier fermé. Or toi tu veux connaitre le nom de la feuille presente dans un classeur, il faut donc l'ouvrir au prealable et recuperer le nom de cette feuille.
 
Donc dans ta boucle, tu ouvres le fichier et tu recuperes le nom de la feuille que tu mets dans la variable NomFeuille. Juste avant la ligne 28


---------------
Soyez malin, louez entre voisins !
n°2009281
@pierre
Posté le 15-07-2010 à 13:36:49  profilanswer
 

aïe ! jai plus de 250 fichiers, si je les ouvres, ça va prendre un temps fou ! Déjà rien que la recherche récurssive me prend près de 7 min, ya pas d'autre solution, kiki29 en propose une plus bas :

 

NomFeuille = Left$(ShImport.Range("A" & NumeroLigne), 15)

 

malheuresement, elle ne donne rien... ou peut etre l'utilise je mal?

 

en plus théoriquement je n'ais pas besoin de connaitre le nom de la feuille car il y en a qu'une seule...
Escusez moi de ma probable naïveté, je m'y connais peu en VBA...


Message édité par @pierre le 15-07-2010 à 13:52:20
n°2009381
kiki29
Posté le 16-07-2010 à 02:06:26  profilanswer
 

Salut,on peut via ADODB lire le nom des feuilles de classeurs sans ouvrir ces classeurs
mais cette méthode renvoie dans le cas de classeurs à feuilles multiples le nom des feuilles dans
l'ordre alphabétique qui ne correspond pas forcément à l'ordre des onglets dans ces classeurs
 
Le principal intéret de lire sans ouvrir les classeurs réside dans le fait que si l'on a
un plugin antivirus activé ( style Norton,AVG etc ) est de ne pas lancer ce dernier à chaque ouverture
 
La solution d'ouverture de chaque classeur ne sera pas forcément si lente mais pour le moment pas le temps
de mettre en place cette solution


Message édité par kiki29 le 16-07-2010 à 12:20:31
n°2009450
@pierre
Posté le 16-07-2010 à 11:11:27  profilanswer
 

J'ai regarder votre lien kiki29 et c'est bon, tout est nickel ça marche, merci bcp!

n°2009704
kiki29
Posté le 17-07-2010 à 18:24:02  profilanswer
 

La version texte


'   Cocher références Microsoft ActiveX Data Objects 2.x Library
'                     Microsoft ADO Ext 2.x for DLL and Security
'                     Microsoft Scripting Runtime
 
'   ShImport : CodeName attribué à la feuille
'   Affecter un bouton à la procédure SelDossier          
       
Option Explicit
 
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (x As Currency) As Boolean
 
Dim Dep As Currency, Fin As Currency, Freq As Currency
Dim NbFichiers As Long
Dim NomFichierRch As String
Dim TabNoms() As String
 
Private Function BackSlashDossier(ByVal TstDossier As String) As String
    If Right(TstDossier, 1) <> "\" Then TstDossier = TstDossier & "\"
    BackSlashDossier = TstDossier
End Function
 
Private Sub Entete()
    With ShImport
        .Cells.Clear
        .Range("A3" ) = "Fichier"
        .Range("B3" ) = "Dossier"
        .Range("C3" ) = "Date Création"
        .Range("D3" ) = "Taille"
        .Range("E3" ) = "Feuille"
        .Range("F3" ) = "A1"
    End With
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
    Argument = "'" & Dossier & "[" & Fichier & "]" & Feuille & "'!" & Range(Cellule).Address(, , xlR1C1)
    ExtraireValeur = ExecuteExcel4Macro(Argument)
End Function
 
Private Sub Import(sDossier As String)
Dim NumeroLigne As Long, i As Long
Dim NomFichier As String
Dim NomDossier As String
Dim NomFeuille As String
 
    QueryPerformanceCounter Dep
    Application.ScreenUpdating = False
 
    NbFichiers = 0
    NumeroLigne = 4
    NomFichierRch = "*.xls"
 
    Entete
    sDossier = BackSlashDossier(sDossier)
    ListeFichiersDansDossier sDossier, True
 
    For i = 1 To NbFichiers
        With ShImport
            NomFichier = .Range("A" & NumeroLigne)
            NomDossier = BackSlashDossier(.Range("B" & NumeroLigne))
            NomFeuille = .Range("E" & NumeroLigne)
            .Cells(NumeroLigne, 6) = ExtraireValeur(NomDossier, NomFichier, NomFeuille, "A1" )
        End With
        NumeroLigne = NumeroLigne + 1
        Application.StatusBar = i & " / " & NbFichiers
    Next i
 
    Mep
 
    QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
    With Application
        .StatusBar = "Terminé : " & Format(((Fin - Dep) / Freq), "0.00 s" )
        .ScreenUpdating = True
    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 r As Long, VerifNom As Boolean, NomFeuille As String
 
    Set FSO = New Scripting.FileSystemObject
    Set DossierSource = FSO.GetFolder(NomDossierSource)
 
    r = ShImport.Range("A" & Rows.Count).End(xlUp).Row + 1
 
    For Each Fichier In DossierSource.Files
        VerifNom = UCase(Fichier.Name) Like UCase(NomFichierRch) And Fichier.Name <> ThisWorkbook.Name
        If VerifNom = True Then
            With ShImport
                .Cells(r, 1) = Fichier.Name
                .Cells(r, 2) = Fichier.ParentFolder
                .Cells(r, 3) = Fichier.DateCreated
                .Cells(r, 4) = Fichier.Size
 
                NomFeuilles .Cells(r, 2) & "\" & .Cells(r, 1)
                .Cells(r, 5) = TabNoms(0)
 
                NbFichiers = NbFichiers + 1
                r = r + 1
            End With
            Application.StatusBar = "Lecture Infos : " & r
        End If
    Next Fichier
 
    If InclureSousDossiers Then
        For Each SousDossier In DossierSource.SubFolders
            ListeFichiersDansDossier SousDossier.Path, True
        Next SousDossier
    End If
 
    Set DossierSource = Nothing
    Set FSO = Nothing
 
End Sub
 
Private Sub Mep()
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
    With ShImport
        .Rows("3:3" ).Font.Bold = True
        .Columns("C:D" ).Select
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    Tri
    With ShImport
        .Columns("A:E" ).Columns.AutoFit
        .Range("A1" ).Select
    End With
End Sub
 
Private Sub NomFeuilles(sNomFichier As String)
Dim Cn As ADODB.Connection
Dim Feuille As ADOX.Table
Dim Cat As ADOX.Catalog
Dim strConn As String, i As Long
 
    Erase TabNoms
    strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sNomFichier & ";" & _
              "extended properties=""Excel 8.0;HDR=NO;IMEX=1"""
 
    Set Cat = CreateObject("ADOX.Catalog" )
    Set Cn = CreateObject("ADODB.Connection" )
 
    Cn.Open strConn
    Set Cat.ActiveConnection = Cn
    i = 0
    For Each Feuille In Cat.Tables
        ReDim Preserve TabNoms(i)
        TabNoms(i) = Replace(Feuille.Name, "$", "" )
        i = i + 1
    Next Feuille
 
    Set Cat = Nothing
    Cn.Close
End Sub
 
Sub SelDossier()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Sélectionner un Dossier"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            DoEvents
            Import .SelectedItems(1)
        End If
    End With
End Sub
 
Private Sub Tri()
Dim LastRow As Long
    With ShImport
        LastRow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A3:F" & LastRow).Sort Key1:=.Range("A4" ), Order1:=xlAscending, _
                                      Key2:=.Range("B4" ), Order2:=xlAscending, _
                                      Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
                                      Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
                                      DataOption2:=xlSortNormal
    End With
End Sub


Message édité par kiki29 le 17-07-2010 à 18:30:59
n°2010033
@pierre
Posté le 19-07-2010 à 14:42:11  profilanswer
 

Merci encore a kiki29 pour ce code !  J'aurais juste encore un petit problème : certains noms de feuilles contiennent des espaces et apparemment, la macro retourne #def dans les cellules de ces feuilles mal nommées... auriez vous une solution?

mood
Publicité
Posté le 19-07-2010 à 14:42:11  profilanswer
 

n°2010133
kiki29
Posté le 19-07-2010 à 17:08:48  profilanswer
 

Salut,modifier ExtraireValeur en y ajoutant Feuille = Replace(Feuille, "'", "" )    


Private Function ExtraireValeur(ByVal Dossier As String, ByVal Fichier As String, _
                                ByVal Feuille As String, ByVal Cellule As String)
Dim Argument As String
    Feuille = Replace(Feuille, "'", "" )    
    Argument = "'" & Dossier & "[" & Fichier & "]" & Feuille & "'!" & Range(Cellule).Address(, , xlR1C1)
    ExtraireValeur = ExecuteExcel4Macro(Argument)
End Function


Message édité par kiki29 le 19-07-2010 à 17:11:06
n°2010150
@pierre
Posté le 19-07-2010 à 17:58:55  profilanswer
 

ok autant pour moi, c'était tout simple. Merci encore !

n°2010158
kiki29
Posté le 19-07-2010 à 18:35:35  profilanswer
 

Re,sinon peut-être mieux en laissant ExtraireValeur intacte
et en plaçant la modif dans NomFeuilles(sNomFichier As String)


Private Sub NomFeuilles(sNomFichier As String)
.....
    For Each Feuille In Cat.Tables
        ReDim Preserve TabNoms(i)
        TabNoms(i) = Replace(Feuille.Name, "$", "" )
        TabNoms(i) = Replace(TabNoms(i), "'", "" )
        i = i + 1
    Next Feuille
.....


Message édité par kiki29 le 19-07-2010 à 19:01:01

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

  Problème pour appelé une feuille & extraire des données sous excel

 

Sujets relatifs
Problème avec une requête mysql en PHPProbléme de float
resolut: probleme sitemap.xmlVBA tcd | problème avec un filtre
[fixed]Problème avec Zend_Soap_ServerProblème d'array
Problème imbrication d'objet Jquery IEDupliquer des lignes ciblées sur excel
Problème de montage des lecteurs réseaux sous windows 7Probleme de compilation
Plus de sujets relatifs à : Problème pour appelé une feuille & extraire des données sous excel


Copyright © 1997-2022 Hardware.fr SARL (Signaler un contenu illicite / Données personnelles) / Groupe LDLC / Shop HFR