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

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
 

Discussions similaires

Haut Bas