Vba Pompages d'une ligne sur 100 ficher

[Bens7]

Bonjours a tous !!
J'ai un dossier avec 100 fichiers excel nomer ainsi : 1 ; 1 (2); 1 (3) ; 1 (4) .... 1 (100)
chaque fichier contient une seul Feuil mais qui n'a pas le meme nom dans chaque fichier

j'aimerais grace a un bouton recuperer la ligne 60 de chacun de ces fichiers et les avoir une a une dans un tableau
Merci a tous ! j'espere que c'est clair lolll....

 

[mikachu]

Re : Vba Pompages d'une ligne sur 100 ficher

Re,

Voici un fichier à tester,il fonctionne chez moi en XL 2007

A changer:
-Le répertoire
- J'ai filtré les fichiers sur .xlsx et xlsm, à retirer si trop.
- For NbColonne = 1 To 100 < changer le 100 par le nombre de colonne à copier.
- supprimer la macro test si elle ne sert plus.

Après, il y a moyen d'optimiser je pense mais pas assez spécialiste.

 

[mapomme]

Re : Vba Pompages d'une ligne sur 100 ficher

(re)Bonsoir Bens7, bbb38, mikachu, à tous,

Un essai dans le fichier joint ( fichier Recup2.xlsm).

Lecode:

Sub Recuperer60()

Const Repert = "D:\EXCEL\@EXCEL-DOWNLOADS\@TEST\Fact\Facturation"
Const LigneDepart = 2

Dim LesFichiers, i, rep As String
Dim Fichier As String, Ligne As Long

Application.ScreenUpdating = False
ThisWorkbook.Sheets("Lignes60").Activate

If Right(Repert, 1) <> "\" Then rep = Repert & "\" Else rep = Repert

Ligne = LigneDepart
Fichier = Dir(rep & "*.xlsm")

Do While Fichier <> ""
  If Not IsArray(LesFichiers) Then
    ReDim LesFichiers(1 To 1)
  Else
    ReDim Preserve LesFichiers(1 To UBound(LesFichiers) + 1)
  End If
  LesFichiers(UBound(LesFichiers)) = rep & Fichier
  Fichier = Dir
Loop

Ligne = LigneDepart
With ThisWorkbook.Sheets("Lignes60")
  .Range("A" & Ligne & ":A" & .Rows.Count).Clear
  If Not IsArray(LesFichiers) Then Exit Sub
  .Range("A" & Ligne).Resize(UBound(LesFichiers)).Value = Application.Transpose(LesFichiers)
  .Range("A" & Ligne).Resize(UBound(LesFichiers)).Sort key1:=.Range("A" & Ligne), Header:=xlNo
   LesFichiers = .Range("A" & LigneDepart).Resize(UBound(LesFichiers)).Value
  .Range("A" & Ligne & ":A" & .Rows.Count).Clear
End With

For i = 1 To UBound(LesFichiers)
  Workbooks.Open LesFichiers(i, 1)
  ActiveWorkbook.ActiveSheet.Rows(60).Copy
  ThisWorkbook.Sheets("Lignes60").Rows(Ligne).PasteSpecial Paste:=xlPasteValues
  Application.DisplayAlerts = False
  ActiveWorkbook.Close Savechanges:=False
  Application.DisplayAlerts = True
  Ligne = Ligne + 1
Next i

Application.CutCopyMode = False
Application.Goto Range("A" & IIf(LigneDepart = 1, 1, LigneDepart - 1)), True
Application.ScreenUpdating = True
End Sub

 

[Bens7]

Re : Vba Pompages d'une ligne sur 100 ficher

MAGIQUE !!
Merci Beaucoup mapomme !3H de gagner par semaine ! c'est enorme merci a tous pour le boulot !

(ou on met resolu ?)😛

 

[Bens7]

Re : Vba Pompages d'une ligne sur 100 ficher

Ma pomme bonjour;
Je reviens sur ce poste malgres que je l'utilise tous les jours j;ai un soucci lorsqu'il y a qu'un seul fichier a pomper ca passe :
voir le post :

https://www.excel-downloads.com/threads/vba-pompage-dune-ligne.211969/

 

[mapomme]

Re : Vba Pompages d'une ligne sur 100 ficher

Bonsoir Bens7 🙂

Je ne me souviens plus très bien mais j'avais éludé le cas où il n'y aurait qu'un seuil fichier .xlsm.
Voici une nouvelle version qui devrait le faire.

Le code:

Option Explicit
Option Base 1
Sub Recuperer60()

Const Repert = "C:\Fact\Facturation"
Const LigneDepart = 2
Dim i&, k&, Ligne&, rep$, LesFichiers(), Fichier$

Application.ScreenUpdating = False
ThisWorkbook.Sheets("Lignes60").Activate

If Right(Repert, 1) <> "\" Then rep = Repert & "\" Else rep = Repert
Fichier = Dir(rep & "*.xlsm")
Do While Fichier <> ""
  k = k + 1
  ReDim Preserve LesFichiers(1 To k)
  LesFichiers(k) = rep & Fichier
  Fichier = Dir
Loop

With ThisWorkbook.Sheets("Lignes60")
  .Range("A" & LigneDepart & ":A" & .Rows.Count).Clear
  If k = 0 Then Exit Sub
  .Range("A" & LigneDepart).Resize(k).Value = Application.Transpose(LesFichiers)
  If k > 1 Then .Range("A" & LigneDepart).Resize(k).Sort _
            key1:=.Range("A" & LigneDepart), Header:=xlNo
  LesFichiers = .Range("A" & LigneDepart).Resize(k + 1).Value
  .Range("A" & LigneDepart & ":A" & .Rows.Count).Clear

  Ligne = LigneDepart
  For i = 1 To k
    Workbooks.Open LesFichiers(i, 1)
    ActiveWorkbook.ActiveSheet.Rows(60).Copy
    .Rows(Ligne).PasteSpecial Paste:=xlPasteValues
    Application.DisplayAlerts = False
    ActiveWorkbook.Close Savechanges:=False
    Application.DisplayAlerts = True
    Ligne = Ligne + 1
  Next i
End With

Application.CutCopyMode = False
Application.Goto Range("A" & IIf(LigneDepart = 1, 1, LigneDepart - 1)), True
Application.ScreenUpdating = True
End Sub