Extraire donnée sans ouvir le fichier

[yannlion]

Bonsoir le forum,

Après de nombreuses recherches, j'ai tenté d'écrire une macro pour extraire des données de dizaines de fichier (mon niveau est vba est débutant ...).

Sub recup()
Range("B2").Select
Chemin = "C:\Users\Yannick\Desktop\2015\"
Fichier = Dir(Chemin & "*.xls")

Do While Fichier <> ""
Workbooks.Open Filename:=Chemin & Fichier
If Sheets("FJUN").Visible = -1 Then
    Sheets("FJUN").Range("F4:H" & Range("F65536").End(xlUp).Row & ",AO4:AP" & Range("F65536").End(xlUp).Row).Copy
    ThisWorkbook.Activate
    ActiveSheet.Paste
    Windows(Fichier).Activate
    Application.CutCopyMode = False
End If
ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
Range("B65536").End(xlUp).Offset(1, 0).Select
Fichier = Dir
Loop
End Sub

J'arrive bien au résultat escompté mais je souhaiterais faire la même chose surtout sans ouvrir les fichiers et en ne copiant que les valeurs.
Je suis aussi ouvert à toute simplification

Merci d'avance
Yannlion

 

[yannlion]

Re : Extraire donnée sans ouvir le fichier

Bonsoir Martial,

J'ai réussi à ajouter la seconde plage en fonction de la 1ère lettre ainsi que le classement sur colonne G.

Sub extractionValeurCelluleClasseurFerme()
  Dim Source As ADODB.Connection
  Dim Rst As ADODB.Recordset
  Dim ADOCommand As ADODB.Command
  Dim Fichier$, Cellule$, Feuille As Worksheet
  Dim Plage(), Plage2(), Col()
  Plage = Array("F4:H400", "AO4:AP400")
  Plage2 = Array("F4:H400", "AW4:AX400")
  Col = Array(2, 5)
  For i = 1 To Sheets.Count
    Sheets(i).Range("B2:F400").ClearContents
  Next
    Fichier = Dir(ThisWorkbook.path & "\*.xls")
     Do While Fichier <> ""
      If Fichier <> ThisWorkbook.Name Then
        Set Source = New ADODB.Connection
        Source.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
          "Data Source=" & ThisWorkbook.path & "\" & Fichier & ";Extended Properties=""Excel 12.0;HDR=no;"";"
        For Each Feuille In ActiveWorkbook.Worksheets
          If Left(Feuille.Name, 1) = "F" Or Left(Feuille.Name, 1) = "M" Then
            For i = 0 To 1
                Cellule = Plage(i)
                Set ADOCommand = New ADODB.Command
                With ADOCommand
                    .ActiveConnection = Source
                    .CommandText = "SELECT * FROM [" & Feuille.Name & "$" & Cellule & "]"
                End With
                Set Rst = Source.Execute("[" & Feuille.Name & "$" & Cellule & "]")
                With Feuille
                .Cells(65536, Col(i)).End(3)(2).CopyFromRecordset Rst
                End With
    Range("A1").Select
            Next i
            Rst.Close
          Else
            For i = 0 To 1
                Cellule = Plage2(i)
                Set ADOCommand = New ADODB.Command
                With ADOCommand
                    .ActiveConnection = Source
                    .CommandText = "SELECT * FROM [" & Feuille.Name & "$" & Cellule & "]"
                End With
                Set Rst = Source.Execute("[" & Feuille.Name & "$" & Cellule & "]")
                With Feuille
                .Cells(65536, Col(i)).End(3)(2).CopyFromRecordset Rst
                End With
            Next i
            Rst.Close
        End If
        Next
        Source.Close
        Set Source = Nothing
        Set Rst = Nothing
        Set ADOCommand = Nothing
      End If
      Fichier = Dir
    Loop

 For nb = 1 To Worksheets.Count
 
 Range("A1").Select
    Sheets(nb).Sort.SortFields.Clear
    Sheets(nb).Sort.SortFields.Add Key:=Range( _
        "G2:G400"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With Sheets(nb).Sort
        .SetRange Range("A1:G400")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
  End With
Next
    
Beep
End Sub

Il y a peut être plus "propre" mais je n'ai pas trouvé mieux (ça clignote pas mal lors du classement !)

Pour le "_", c'était un faux problème ; je viens de découvrir qu'en fait une partie des fichiers avait l'onglet "FJUN-Elite" qui se nommait "FJUNE" du coup il faut que je me crée une macro qui renomme automatiquement cet onglet en "FJUN-Elite" quand il existe dans tous les fichiers du dossier ... (je pensais en voir le bout mais non !)

Yannlion

 

[yannlion]

Re : Extraire donnée sans ouvir le fichier

Bonjour Martial,

Je rencontre un soucis dans l'application de la macro :

                .Cells(65536, Col(i)).End(3)(2).CopyFromRecordset Rst

copie F4:H400 des classeurs fermés sur la première ligne vide en F:H de mon classement et AO4:AP400 des classeurs fermés sur la première ligne vide en AO:AP de mon classement.

Le soucis est qu'il peut arriver qu'il n'y ait pas de valeur en AO4:AP400 sur certain onglet (1 seul athlète forfait et donc sans note).
Du coup j’ai un décalage sur toutes les copies suivantes.

Il faudrait que AO4:AP400 se copie forcément sur la même ligne que F4:H400.

Je sais pas si je suis clair ...

Merci

Bon weekend
Yannlion

 

[Yaloo]

Re : Extraire donnée sans ouvir le fichier

Bonjour yannlion, le forum,

Fais un test avec ça (à vérifier, pas le temps pour le moment)

Sub extractionValeurCelluleClasseurFerme()
  Dim Source As ADODB.Connection
  Dim Rst As ADODB.Recordset
  Dim ADOCommand As ADODB.Command
  Dim Fichier$, Cellule$, Feuille As Worksheet
  Dim Plage(), Plage2(), Col(), i&, l&
  Plage = Array("F4:H400", "AO4:AP400")
  Plage2 = Array("F4:H400", "AW4:AX400")
  Col = Array(2, 5)
  For i = 1 To Sheets.Count
    Sheets(i).Range("B2:F400").ClearContents
  Next
    Fichier = Dir(ThisWorkbook.Path & "\*.xls")
     Do While Fichier <> ""
      If Fichier <> ThisWorkbook.Name Then
        Set Source = New ADODB.Connection
        Source.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
          "Data Source=" & ThisWorkbook.Path & "\" & Fichier & ";Extended Properties=""Excel 12.0;HDR=no;"";"
        For Each Feuille In ActiveWorkbook.Worksheets
          l = Feuille.[B65536].End(3)(2).Row
          If Left(Feuille.Name, 1) = "F" Or Left(Feuille.Name, 1) = "M" Then
            For i = 0 To 1
                Cellule = Plage(i)
                Set ADOCommand = New ADODB.Command
                With ADOCommand
                    .ActiveConnection = Source
                    .CommandText = "SELECT * FROM [" & Feuille.Name & "$" & Cellule & "]"
                End With
                Set Rst = Source.Execute("[" & Feuille.Name & "$" & Cellule & "]")
                With Feuille
                .Cells(l, Col(i)).CopyFromRecordset Rst
                End With
    ' Range("A1").Select   Pourquoi ????
            Next i
            Rst.Close
          Else
            For i = 0 To 1
                Cellule = Plage2(i)
                Set ADOCommand = New ADODB.Command
                With ADOCommand
                    .ActiveConnection = Source
                    .CommandText = "SELECT * FROM [" & Feuille.Name & "$" & Cellule & "]"
                End With
                Set Rst = Source.Execute("[" & Feuille.Name & "$" & Cellule & "]")
                With Feuille
                .Cells(l, Col(i)).CopyFromRecordset Rst
                End With
            Next i
            Rst.Close
        End If
        Next
        Source.Close
        Set Source = Nothing
        Set Rst = Nothing
        Set ADOCommand = Nothing
      End If
      Fichier = Dir
    Loop
'etc.....

Le tri peut être simplifié, je vois ça ce soir.

A+

Martial

 

[yannlion]

Re : Extraire donnée sans ouvir le fichier

Re,

Cela fonctionne bien !
Pour le tri j'ai tenté de simplifier avec :

Dim sh As Worksheet
For Each sh In ActiveWorkbook.Sheets
sh.Activate
Range("B2:G" & Range("B65536").End(xlUp).Row).Sort Key1:=Range("G2"), Order1:=xlAscending
Next sh

ça à l'air plus rapide !

Yannlion