XL 2013 Récupération d'une plage d'une feuille de chaque classeur d'un dossier

J

JLE

XLDnaute Junior
Bonjour,
Voilà plusieurs semaines que je bute sur la rapidité d'une macro qui fonctionne mais qui prend enormément de temps.

J'ai des classeurs dans un dossier qu'il faut parcourir pour récupérer une plage d'une feuille.

Exemple
16-0001 - XX - Nomclient - affaire - objet.xlsx ou xls --> à ne pas récupérer
16-0001 - XX - Nomclient - affaire - objet2.xlsx ou xls --> à ne pas récupérer
16-0001 - XX - Nomclient - affaire - objet3.xlsx ou xls --> à ne pas récupérer
16-0001 - XX - Nomclient - affaire - objet4.xlsx ou xls --> à ne pas récupérer
16-0001 - XX - Nomclient - affaire - objet5.xlsx ou xls --> à récupérer
16-0001 - divers excel.xlsx ou xls --> à ne pas récupérer
16-0002 - XX - Nomclient - affaire - objet.xlsx ou xls --> à récupérer
16-0003 - XX - Nomclient - affaire - objet.xlsx ou xls --> à ne pas récupérer
16-0003 - XX - Nomclient - affaire - objet2.xlsx ou xls --> à ne pas récupérer
16-0003 - XX - Nomclient - affaire - objet3.xlsx ou xls --> à ne pas récupérer
16-0003 - XX - Nomclient - affaire - objet4.xlsx ou xls --> à récupérer
17-0001 - XX - Nomclient - affaire - objet.xlsx ou xls --> à ne pas récupérer
17-0001 - XX - Nomclient - affaire - objet2.xlsx ou xls --> à ne pas récupérer
17-0001 - XX - Nomclient - affaire - objet3.xlsx ou xls --> à ne pas récupérer
17-0001 - XX - Nomclient - affaire - objet4.xlsx ou xls --> à ne pas récupérer
17-0001 - XX - Nomclient - affaire - objet5.xlsx ou xls --> à récupérer
17-0001 - divers excel.xlsx ou xls --> à ne pas récupérer
17-0002 - XX - Nomclient - affaire - objet.xlsx ou xls --> à récupérer
17-0003 - XX - Nomclient - affaire - objet.xlsx ou xls --> à ne pas récupérer
17-0003 - XX - Nomclient - affaire - objet2.xlsx ou xls --> à ne pas récupérer
17-0003 - XX - Nomclient - affaire - objet3.xlsx ou xls --> à ne pas récupérer
17-0003 - XX - Nomclient - affaire - objet4.xlsx ou xls --> à récupérer
et ainsi de suite

Puis dans chacun des fichiers notés à récupérer, il faut extraire la plage B4:B304 de la Budget.
Il y a environ 1850 fichiers dans ce dossier

Si quelqu'un a une idée, je suis preneur : j'ai imaginé utiliser un classeur tampon mais si un fichier change d'indice ou un nouveau fichier est crée, il ne se retrouvera pas dans ce classeur tampon à moins de recommencer la procédure.. mais qui est longue !

Peut être que ma macro est bricolée alors soyez indulgent :). La voilà :

VB: 
Public tablo()
Public tablodef()
Public fichierimportation


Sub intègredansletableaudéfinitif()

For maxtablo = 0 To UBound(tablo, 2)
If tablo(0, maxtablo) = "0,00" Or tablo(0, maxtablo) = 0 Then Exit For
Next maxtablo



If oncontinueoupas = 0 Then
positionref = 0
maxtablo = maxtablo - 1
Else
positionref = UBound(tablodef, 2) + 1
maxtablo = UBound(tablodef, 2) + maxtablo
End If

ReDim Preserve tablodef(2, maxtablo)

i = 0
For ligneàcopier = positionref To maxtablo
    tablodef(0, ligneàcopier) = tablo(0, i)
    tablodef(1, ligneàcopier) = i + 1
    tablodef(2, ligneàcopier) = fichierimportation
    i = i + 1
Next ligneàcopier



End Sub


Sub trouverlesdevisdéf()
Dim Var As Variant
Dim param&, i&, k As Byte
Dim Source As Object, Requete As Object
Dim onglet As String, Plage As String, Fichier As String
Dim texte_SQL As String


oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True

Application.ScreenUpdating = False

Chemin = "L:\Chiffrages\"
onglet = "Budget"
Plage = "B3:B304"
oncontinueoupas = 0

'totalfichiertotal = NbFich("L:\Chiffrages\", "*.xls*")
'totalfichier = NbFich("L:\Chiffrages\", "18" & "*.xls*")
'tot = 0


fichierimportation = Dir(Chemin & "*.xls*", vbDirectory)


Do While fichierimportation <> ""


''Progression en %
'tot = tot + (totalfichier / totalfichiertotal)
'Application.StatusBar = Application.WorksheetFunction.RoundUp(tot * 100 / totalfichier, 0) & " %" '"MAJ en cours : " & Application.WorksheetFunction.RoundUp(tot * 100 / totalfichier, 0) & " %"


fichierimportationsuivant = Dir()


If IsNumeric(Left(fichierimportation, 2)) Then
    If Left(fichierimportation, 2) = "17" Then

         
            '********Attention avec les ' s'il y en a 1 dans le nom, il faut le doublé
            fichierimportation2 = Replace(fichierimportation, "'", "''")
  
            'première vérif avec le OLD enlevé ou -old ou RECAP VALEUR
'            If Not fichierimportation2 Like "* - OLD - *" Then
'            If Not fichierimportation2 Like "*-OLD*" Then
'            If Not fichierimportation2 Like "* - RECAP VALEUR*" Then
'            If Not fichierimportation2 Like "*-old*" Then
'            If Not fichierimportation2 Like "*.xlsxold*" Then
'            If Not fichierimportation2 Like "*.xlsold*" Then
'            If Not fichierimportation2 Like "* - BUDGET*" Then
                      
                'deuxième vérif
                Var = ExecuteExcel4Macro("'" & Chemin & "[" & fichierimportation2 & "]Page de garde'!R1C1")
                If Not IsError(Var) Then
  
                    'troisième vérif
                    Var = ExecuteExcel4Macro("'" & Chemin & "[" & fichierimportation2 & "]Relance'!R1C1")
                    If Not IsError(Var) Then

                    If Right(fichierimportation, 1) = "x" Then
                    verifiindice = IsNumeric(Right(Left(fichierimportation, Len(fichierimportation) - 5), 1))
                    End If
                    If Right(fichierimportation, 1) = "s" Then
                    verifiindice = IsNumeric(Right(Left(fichierimportation, Len(fichierimportation) - 4), 1))
                    End If
                  
                'on vérifie qu'il n'y a pas d'autre version d'indice
                            If verifiindice = Faux Then
                                    If Right(fichierimportation, 1) = "x" Then
                                    fichierimportation3 = Left(fichierimportation, Len(fichierimportation) - 5)
                                    finfichier = "sx"
                                    End If
                                        If Right(fichierimportation, 1) = "s" Then
                                        fichierimportation3 = Left(fichierimportation, Len(fichierimportation) - 4)
                                        finfichier = "s"
                                        End If
                                            For c = 2 To 30
                                                fichierimportation3 = Replace(fichierimportation3, "'", "''")
                                                testexistence = fichierimportation3 & c & ".xl" & finfichier
                                                Application.DisplayAlerts = False
                                                    Var = ExecuteExcel4Macro("'" & Chemin & "[" & testexistence & "]Page de garde'!R1C1")
                                                    If Not IsError(Var) Then
                                                    [IV1].FormulaLocal = "=NBVAL('" & Chemin & "\[" & testexistence & "]Budget'!$A:$A)"
                                                    fichierimportation = Replace(testexistence, "''", "'")
                                                    Else
              
                                                    Exit For
                                                    End If
                                                Application.DisplayAlerts = True
                                            Next c
                                   
                                  
'connexion ADO
Plage = "B4:B" & [IV1] + 1
Set Source = CreateObject("ADODB.Connection")
Source.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chemin & fichierimportation & ";Extended Properties=""Excel 12.0;HDR=YES;"""
texte_SQL = "SELECT * FROM [" & onglet & "$" & Plage & "]"
Set Requete = CreateObject("ADODB.Recordset")
Set Requete = Source.Execute(texte_SQL)

tablo() = Requete.GetRows
intègredansletableaudéfinitif
oncontinueoupas = 1

'libère les pointeurs
Set Requete = Nothing
Set Source = Nothing

                '                    End If
                            End If
                    End If
                End If
'            End If
'            End If
'            End If
'            End If
'            End If
'            End If
'            End If
    End If
End If

    fichierimportation = fichierimportationsuivant

Loop

Application.ScreenUpdating = True
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar

UserForm1.ListBox1.Column = tablodef



End Sub
 
Trier par date Trier par votes

Discussions similaires

N
  • Résolu(e)
Microsoft 365 Transfère de données d'un Userform vers un tableau structuré d'une feuille de calcul
Réponses
4
Affichages
213
NONO14
N
mromain
Génération de QR Codes
Réponses
1
Affichages
739
Cousinhub
Cousinhub
T
  • Question
XL 2021 message si une valeur n'existe pas
Réponses
6
Affichages
648
target
T
PHV.FSM
  • Question
XL 2016 Calculer la position sur l'écran d'une position sur la grille (XL 2003)
2
Réponses
27
Affichages
3 K
Nicolas JACQUIN
Nicolas JACQUIN
J
  • Question
XL 2019 Sélection d'une plage de données via .Address
Réponses
2
Affichages
622
jui42
J
M
  • Question
XL 2013 VBA-Envoyer par email "Plage de cellules collée dans un nouveau classeur en gardant formules de certaines cellules
Réponses
2
Affichages
852
MONTREAL2020
M
T
  • Question
XL 2019 pb de restitution de date
Réponses
2
Affichages
594
Phil69970
Phil69970
9
  • Question
Microsoft 365 Copier Coller les données (cellules) de plusieurs feuilles d'un classeur vers plusieurs autres feuilles d'un classeur
Réponses
5
Affichages
1 K
92lever
9
S
  • Question
XL 2019 modifications macro svp
Réponses
3
Affichages
882
Bernard_XLD
Bernard_XLD
G
  • Question
Microsoft 365 Remplir une combobox à partir d'un autre fichier
Réponses
11
Affichages
1 K
gillmo
G

Membres actuellement en ligne

2 membres et 41 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 087
Messages
2 116 084
Membres
112 655
dernier inscrit
fannycordi