VBA: mettre une fonction pause

Version imprimable

Bonjour à tous,

Je reviens vers vous au sujet de ma macro. Le but est qu'elle fasse un vulgaire copier/coller de plusieurs feuilles vers une seule autre afin de concaténer l'ensemble.
En mode pas à pas, tout va bien. Cependant lorsque j’exécute ma macro, elle ne prend pas en compte l'ensemble des fichiers sources.

Du coup je me suis dit que cela pourrait provenir du fait que certaines taches sont plus longues que d'autres à exécuter, le copier/coller de milliers de lignes par exemple. Et donc j'ai mis une fonction pause de quelques secondes avant de passer à la taches suivantes mais le résultat est incorrecte. La 6eme feuille à copier se copie en ligne 2 au lieu de la ligne qui suit la dernière non vide.

Je n'arrive pas à trouver ce qui pourrait expliquer qu'en pas à pas, tout s'effectue correctement.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 Sub concatene() Dim infolog, final As Workbook Dim Nomfichier As String Dim cpt, i As Double dateJ = Date dateYYYY = Right(dateJ, 4) dateMM = Left(Right(dateJ, 7), 2) dateDD = Left(dateJ, 2) dateFic = dateYYYY & dateMM & dateDD cpt = 1 Workbooks.Add ActiveWorkbook.SaveAs Filename:= _ "C:\Users\kguesmia\Documents\Alerte CASSE appro\Risque CASSE au " & dateFic & ".xlsx" _ , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False Application.DisplayAlerts = True Set final = Workbooks.Open(Filename:="C:\Users\kguesmia\Documents\Alerte CASSE appro\Risque CASSE au " & dateFic & ".xlsx") Set infolog = Workbooks.Open(Filename:="C:\Users\kguesmia\Documents\Alerte CASSE appro\Donnees\Liste4_" & dateFic & " .xls") Application.Wait Time + TimeSerial(0, 0, 3) 'attendre 3s infolog.Sheets(1).UsedRange.Copy final.Sheets(1).Range("A" & cpt) Application.Wait Time + TimeSerial(0, 0, 3) 'attendre 3s cpt = final.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row i = 5 Do While i <> 95 Nomfichier = Dir("C:\Users\kguesmia\Documents\Alerte CASSE appro\Donnees\Liste" & i & "_" & dateFic & " .xls") If Nomfichier <> "" Then Set infolog = Workbooks.Open(Filename:="C:\Users\kguesmia\Documents\Alerte CASSE appro\Donnees\Liste" & i & "_" & dateFic & " .xls") Application.Wait Time + TimeSerial(0, 0, 3) 'attendre 3s ' Application.CutCopyMode = False: infolog.Sheets(1).Rows(1).Delete infolog.Sheets(1).UsedRange.Copy final.Sheets(1).Range("A" & cpt + 1) Application.Wait Time + TimeSerial(0, 0, 3) 'attendre 3s infolog.Sheets(1).UsedRange.Copy: Application.CutCopyMode = False infolog.Close SaveChanges:=False cpt = final.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row End If i = i + 1 Loop

18/03/2016, 15h38
Oliv-

Bonjour,
A première vue , rine qui semble justifier cette anomalie.

Ajoute un Doevents après tes Wait
18/03/2016, 15h41
kimou75

Oui je suis d'accord avec vous. A part la volumétrie des données à déplacer, je ne vois pas ce qui pose problème :?

Alors peut-être qu'en codant différemment, j'arriverai à optimiser cela.

Voici un exemple qui fonctionne en principe assez bien

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
Public Sub FusionFichiers()
 
    Dim FichiersImport
    Dim ClasseurCourant As Workbook
    Dim IFichier As Integer
    Dim ClasseurImport As Workbook
    Dim FeuilleImport As Worksheet
    Dim ZoneCopie As Range, ZoneColle As Range
    Dim DerniereLigneRemplie
    Dim Nb_import As Integer
    Dim S As Worksheet
 
 
    Nb_import = 1
    Set ClasseurImport = Workbooks.Add
    Set FeuilleImport = ClasseurImport.Sheets.Add
    FeuilleImport.Name = "Import_" & Nb_import
    FeuilleImport.Cells.Clear
    FichiersImport = Application.GetOpenFilename("Fichiers Excel, *.xls; *.xlsx; *.xlsm", , "Sélectionnez les fichiers à importer", , True)
 
 
    Application.Calculation = xlCalculationManual
    For IFichier = LBound(FichiersImport) To UBound(FichiersImport)
        'Stop
 
        Set ClasseurCourant = Application.Workbooks.Open(FichiersImport(IFichier), , True)
        ClasseurCourant.Activate
        'Call sup_feuilles_vides
        For Each S In ClasseurCourant.Worksheets
 
                S.Activate
 
 
                If S.AutoFilterMode = True Then S.AutoFilterMode = False
                S.Cells.EntireColumn.Hidden = False
                S.Cells.EntireRow.Hidden = False
 
                Set DerniereLigneRemplie = FeuilleImport.Range("A1").SpecialCells(xlLastCell)
                Set ZoneColle = FeuilleImport.Range("A" & DerniereLigneRemplie.Row + DerniereLigneRemplie.Rows.Count)
 
                If ZoneColle.Address = "$A$2" Then Set ZoneColle = ZoneColle.Offset(-1, 0)
 
 
                Set ZoneCopie = S.Range(Range("A1"), Range("A1").SpecialCells(xlLastCell))
 
 
                On Error GoTo errorhandler
                ZoneCopie.Copy ZoneColle
                On Error GoTo 0
 
        Next S
 
 
        ClasseurCourant.Close SaveChanges:=False
 
    Next IFichier
    ClasseurImport.Activate
 
 
 
    Exit Sub
errorhandler:
    If Err = "1004" Then
        Nb_import = Nb_import + 1
Debug.Print Err
        If ZoneCopie.Rows.Count + ZoneColle.Row > Rows.Count Then
            MsgBox "trop de lignes"
            Set FeuilleImport = ClasseurImport.Sheets.Add
            FeuilleImport.Name = "Import_" & Nb_import
            Set ZoneColle = FeuilleImport.Range("A" & FeuilleImport.Range("A1").SpecialCells(xlLastCell).Row)
            Resume
        End If
    Else: MsgBox Err & vbCr & Err.Description
    End If
 
End Sub

18/03/2016, 16h49
ZX12R

pause

Bonjour,

sans entrer dans le détail de ton problème...

L'instruction "Stop" permet de repasser en mode pas à pas.

Cordialement.

Bruno
18/03/2016, 17h24
kimou75

Superbe ton programme Oliv !! merci beaucoup.

Je vais tenter de le comprendre maintenant :-)