Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

vbA pompage d'une ligne

Créer une discussion
  • 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 !

S'inscrire
B

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
 
Trier par date Trier par votes
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
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- 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

E
  • Résolu(e)
XL 2019 transfer listbox vers une colonne à partir de la 4 ligne
Réponses
2
Affichages
236
escudo
E
  • Question Question
Microsoft 365 Méthode Evaluate pour se dispenser d'une boucle imbriquée
Réponses
14
Affichages
492
patricktoulon
  • Résolu(e)
XL 2010 Créer ListObject + Ligne Total
2
Réponses
16
Affichages
852
dysorthographie
C
  • Résolu(e)
XL 2021 VBA : Afficher plusieurs résultats d'une boucle dans une cellule
Réponses
3
Affichages
258
Claudinedu13
C
S
  • Résolu(e)
Microsoft 365 VBA Match: comment éviter l'erreur?
2
Réponses
29
Affichages
696
Dranreb
A
  • Question Question
insertion d'une ligne automatique dans un tableau excel.
Réponses
1
Affichages
478
sylvanu
G
  • Résolu(e)
XL 2016 Pb de tri et sous totaux
2
Réponses
27
Affichages
665
Gestionnaire_rh
G
M
  • Question Question
XL 2013 MACRO VBA pour imprimer tous les bulletins d'un établissement scolaire
Réponses
4
Affichages
509
MBEPID
M
X
  • Question Question
XL 2021 Transformation de données sur une ligne en plusieurs lignes
Réponses
9
Affichages
244
xavieralvaro
X
S
  • Résolu(e)
XL 2016 Coller nom classeur sur plage cellules
Réponses
9
Affichages
223
safranien
S
M
  • Question Question
XL 2021 VBA Excel Erreur 2023
Réponses
2
Affichages
285
MICHIS
M
F
  • Question Question
Microsoft 365 aide VBA excel
Réponses
4
Affichages
464
Oneida
M
  • Question Question
Microsoft 365 Erreur sur mon Code VBA
Réponses
2
Affichages
515
Gégé-45550
  • Question Question
XL 2016 annulation ou désactivation de macro
2
Réponses
27
Affichages
566
job75
T
  • Résolu(e)
XL 2019 Filtrer certains champs au démarrage avec vba
2
Réponses
15
Affichages
501
telemarrk
T
A
  • Question Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
352
patricktoulon
  • Question Question
Autres la fonction similaire
Réponses
11
Affichages
641
patricktoulon
C
  • Question Question
XL 2021 VBA excel
Réponses
4
Affichages
175
CDALE
C
J
  • Question Question
Microsoft 365 Copie des onglets dans un fichier séparé depuis une liste en VBA
Réponses
3
Affichages
145
job75
G
  • Question Question
XL 2021 Macro pour changer les titres de fichier d'archive
Réponses
3
Affichages
297
fanch55
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…