vbA pompage d'une ligne

  • Initiateur de la discussion Initiateur de la discussion Bens7
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Bens7

XLDnaute Impliqué
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 !

Code:
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
 
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:

Code:
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
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
2
Affichages
285
Réponses
4
Affichages
464
Réponses
2
Affichages
515
  • Question Question
XL 2021 VBA excel
Réponses
4
Affichages
175
Retour