vbA pompage d'une ligne

[Bens7]

Bonjour a tous !
On ma fait un macro pour copier la ligne 63 de tous les fichiers d'un dossier (\\BEN-PC\RDV\EN COURS\) et les mettre une a une dans un tableau le probleme c'est que si ya que un seul fichier ca pompe pas et ca bug si vous pouvez m'aider merci !

Option Explicit

Sub Pompage()

Const Repert = "\\ben-pc\rdv\EN COURS\" 'MODIFIER LE DOSSIER A POMPER
Const LigneDepart = 2

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

Application.ScreenUpdating = False
ThisWorkbook.Sheets("Feuil1").Activate 'nom de feuil pompage

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("Feuil1") 'nom de feuil pompage
  .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(50).Copy 'LIGNE 50 A POMPER
  ThisWorkbook.Sheets("Feuil1").Rows(Ligne).PasteSpecial Paste:=xlPasteValues 'nom de feuil pompage
  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

 

[apnart]

Re : vbA pompage d'une ligne

Sur quelle ligne le debugger s'arrête ?

 

[Staple1600]

Re : vbA pompage d'une ligne

Bonsoir à tous

Essaies en ajoutant tout en haut de ton module
Option Base 1

Voir pour les détails ici
Ce lien n'existe plus

 

[Bens7]

Re : vbA pompage d'une ligne

Desole je relance le POst :
ca bloque la :
For i = 1 To UBound(LesFichiers)

et j'ai mis Option Base 1 a la place, avant, et apres de option explicit rien y fait

 

[pierrejean]

Re : vbA pompage d'une ligne

Bonjour à tous

A tester

  For i = LBound(LesFichiers) To UBound(LesFichiers)

 

[Bens7]

Re : vbA pompage d'une ligne

Non desole je remt le code a jour d'aujourdhui je precise que cela bug quand ya 1 fichier excel et 1 fichier pdf du meme nom exemple :
09 88 66 44 11.xlsx et 09 88 66 44 11.pdf

Mais si j'ai 2 xlsx et meme 0 pdf ca pompe:

Option Explicit



Sub Pompage()

'---------------------------------- POMPAGE
' ----- PROGRAMME DE POMPAGE


Const Repert = "D:\PANNEAU\RESEAUX\EN COURS\" 'MODIFIER LE DOSSIER A POMPER
Const LigneDepart = 2

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

Application.ScreenUpdating = False
ThisWorkbook.Sheets("POMPAGE").Activate 'SHEETS CIBLE

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

Ligne = LigneDepart
Fichier = Dir(rep & "*.xlsx") 'FORMAT DE FICHIER

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("POMPAGE")
  .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 = LBound(LesFichiers) To UBound(LesFichiers)
  Workbooks.Open LesFichiers(i, 1)
  ActiveWorkbook.ActiveSheet.Rows(60).Copy 'LIGNE 60 A POMPER
  ThisWorkbook.Sheets("POMPAGE").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



'---------------------------------------- DEPLACEMENT DES LIGNES
'Selection de la plage à copier
   Sheets("POMPAGE").Range("A2:Q999").Copy
  'Sélection de la cellule de debut de copie
  Sheets("LISTING").Activate
 Sheets("LISTING").Range("a65536").End(xlUp).Offset(1, 0).Select
  
             'Collage de la plage de cellule
  ActiveSheet.Paste
  
             'retour POMPAGE
  Sheets("POMPAGE").Activate
  Sheets("POMPAGE").Range("A2:Q999").ClearContents
    Sheets("LISTING").Activate
  Sheets("LISTING").[A1].Select
  MsgBox "LIGNE COPIER DANS LISTING"

End Sub