Code à repenser : temps d'exécution trop long !

Version imprimable

Voir 40 message(s) de cette discussion en une page

2 pièce(s) jointe(s)

Code à repenser : temps d'exécution trop long !

Salut à tous
:hola: Je fais appel à votre expérience en Excel et en VBA pour me donner des conseils quant à ma macro :hola:
Il s'agit du traitement d'une extraction depuis un logiciel mal foutu. Ce logiciel traite d'événements de maintenance, et me sort un tableau excel où chaque ligne devrait correspondre à un événement, les colonnes en seraient les différentes info (date, numéro etc)
OR cette extraction crée une nouvelle ligne à chaque fois qu'il y a un retour à la ligne dans un champ d'origine : typiquement si dans le champ description le mec qui l'a écrit a mis 2 sauts de ligne, PAF je me retrouve avec 3 lignes au lieu d'une ! :mur:
Une image vaut mieux que toute mon explication :
Voila ce que j'ai au départ :

Pièce jointe 185973

et voila ce que je veux obtenir :

Pièce jointe 185974

J'y arrive mais cela prend trop longtemps, cela fait planter mon ordi, et si je veux que cela intéresse d'autres collègues, je dois vraiment réussir à rendre tout ça plus rapide !
Voila donc mon code en question (je vous épargne les lignes de mise en forme de base), mon besoin est surtout sur la partie "concaténation" :

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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
 
Sub EXTRACT_Ticket_Layout()
 
    With wsticket
 
    '===============================================================
    '%%%%%%%%%%%%%%%%%%%%%%% Paramétrisation %%%%%%%%%%%%%%%%%%%%%%%
    rtickcol = .Cells.Find(What:="INC00*", SearchOrder:=xlByRows).Offset(-1, 0).row
    If .Cells(rtickcol, 1) = "" Or wsticket.Cells(rtickcol, 1) Is Nothing Then
        ctickfirst = .Cells(rtickcol, 1).End(xlToRight).Column
    Else
        ctickfirst = 1
    End If
    cticklast = .Cells(rtickcol, ctickfirst).End(xlToRight).Column
    '===============================================================
 
 
    '===============================================================
    '%%%%%%%%%% Suppression des colonnes et lignes vides %%%%%%%%%%%
    If Not rtickcol = 1 Then
        For i = rtickcol - 1 To 1 Step -1
            .Rows(i).Delete Shift:=xlUp
        Next i
        rtickcol = 1
    End If
 
    If Not ctickfirst = 1 Then
        For i = ctickfirst - 1 To 1 Step -1
            .Columns(i).Delete Shift:=xlToLeft
        Next i
        cticklast = cticklast - ctickfirst + 1
        ctickfirst = 1
    End If
    '===============================================================
 
 
 
 
    '===============================================================
    '%%%%%%%%%%%%%% Défusion de toutes les cellules %%%%%%%%%%%%%%%%
    With .Cells
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    '===============================================================
 
 
 
 
    '===============================================================
    '%%%%%%%%%%%%%%% Concaténation sur une cellule %%%%%%%%%%%%%%%%%
    cticknumber = .Cells.Find(What:="INC00*", SearchOrder:=xlByRows).Offset(-1, 0).Column
    rtickend = .Cells(65536, cticknumber).End(xlUp).Offset(1, 0).row - 1
 
    itickpre = rtickend
    iticknext = .Cells(rtickend + 1, cticknumber).End(xlUp).row
 
    'tant qu'on est pas au dernier avis
    While Not iticknext = rtickcol
        'si il y a des lignes vides à concaténer
        If Not iticknext = itickpre Then
            For i = itickpre To iticknext + 1 Step -1
                For j = ctickfirst To cticklast
                    If Not (.Cells(i, j) Is Nothing Or .Cells(i, j) = "") Then
                        'si il y a un signe égal on passe en format texte
                        If Not InStr(.Cells(i, j), "=") = 0 Then
                            .Cells(i, j).NumberFormat = "@"
                        End If
                        If Not (.Cells(i - 1, j) Is Nothing Or .Cells(i - 1, j) = "") Then
                            If Not InStr(.Cells(i - 1, j), "=") = 0 Then
                                .Cells(i - 1, j).NumberFormat = "@"
                            End If
                            .Cells(i - 1, j) = .Cells(i - 1, j) & Chr(10) & .Cells(i, j)
                        Else
                            .Cells(i - 1, j) = .Cells(i, j)
                        End If
                        If .Cells(i - 1, j).NumberFormat = "@" Then
                            .Cells(i - 1, j).NumberFormat = "General"
                        End If
                    End If
                Next j
                .Rows(i).Delete
            Next i
 
        End If
        itickpre = iticknext - 1
        If .Cells(itickpre, cticknumber) Like "INC00*" Then
            iticknext = itickpre
        Else
            iticknext = .Cells(iticknext, cticknumber).End(xlUp).row
        End If
    Wend
    rtickend = .Cells(65536, cticknumber).End(xlUp).Offset(1, 0).row - 1
    '===============================================================

Voila Voila, j'espère intéresser des gens et je remercie toute aide ou suggestion, je ne vois pas trop comment améliorer tout ça !
:mouarf2:

21/08/2015, 11h19
Quentin77170
Bonjour à toi,

Je ne pense pas avoir tout compris à tes tableaux, pourrais-tu nous en joindre un extrait ? Avant tout, je ne sais pas si tu les as utilisées, mais il y a quelques astuces pour gagner en temps de traitement, parfois énormément, même :
Code:

1 2 3 4 5 Application.Calculation = xlCalculationManual Application.ScreenUpdating = False '[TON CODE] Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic
21/08/2015, 11h41
MobyKDIK

2 pièce(s) jointe(s)
D'abord merci de ta réponse !
J'ai bien ajouté dès le départ les commandes classiques d'optimisation :
Code:

1 2 3 4 5 Application.ScreenUpdating = False Application.DisplayStatusBar = False ActiveSheet.DisplayPageBreaks = False Application.Calculation = xlCalculationManual
Je n'arrive pas à le mettre en pièce jointe, je ne peux que te fournir une image plus claire, plus complète :pastaper:

AVANT :
Pièce jointe 185987

APRES :
Pièce jointe 185986

Tu peux y voir qu'avant les cellules description sont fractionnées, celles d'à côté sont fusionnées
Et après je l'ai ai réunies en une ligne pour chaque événement

Bonjour,

Sans classeur exemple difficile de tester mais regarde ce code sur une copie de ton classeur pour voir déjà le résultat obtenu et ce qui reste à faire :

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
 
Sub Test()
 
    Dim WsTicket As Worksheet
    Dim Plage As Range
    Dim Cel As Range
 
    Set WsTicket = Worksheets("Feuil1") '<--adapter le nom de la feuille
 
    'défini la plage sur les cellules utilisées
    With WsTicket
 
        Set Plage = .Range(.Cells(1, 1), _
                    .Cells(.Cells.Find("*", .[A1], -4123, , _
                    1, 2).Row, .Cells.Find("*", .[A1], -4123, , _
                    2, 2).Column))
 
        'ou :
        'Set Plage = .UsedRange
 
    End With
 
    'supprime toutes les fusions
    Plage.MergeCells = False
 
    'boucle sur les cellules de la plage contenant une valeur et remplace le saut de ligne par un espace
    For Each Cel In Plage.SpecialCells(xlCellTypeConstants)
 
        'fonction Excel "Epurage", problème ici, les mots vont être collés les uns au autres !
        'Cel.Value = Application.WorksheetFunction.Clean(Cel.Value)
        Cel.Value = Replace(Cel.Value, Chr(10), " ") 'remplace par un espace
 
    Next Cel
 
End Sub

Hervé.

Ici, en passant par un tableau intermédiaire :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 
Sub Test2()
 
    Dim Tbl
    Dim Plage As Range
    Dim I As Long
    Dim J As Long
 
    Set Plage = Worksheets("Feuil1").UsedRange '<--adapter le nom de la feuille
 
    Tbl = Plage
 
    For I = 1 To UBound(Tbl, 1)
 
        For J = 1 To UBound(Tbl, 2)
            Tbl(I, J) = Replace(Tbl(I, J), Chr(10), " ") 'remplace par un espace
        Next J
 
    Next I
 
    Plage = Tbl
 
End Sub

Hervé.

24/08/2015, 10h56
patricktoulon

re

bonjour
c'est un cas assez récurent les importation mal concues

selon ta preùiere capture je dis bien selon ta 1 ere capture supprimer les sauts de ligne n'est pas ce qu'il faut faire
en effet les données sont bien sur plusieur lignes et pas dans une seule cellule avec des saut de ligne ce qui est tout a fait diférent dans le sens ou la manoeuvre va etre completement différente

solution
boucler sur la colonne A recupérer l'index de ligne
avec l'index de ligne on a deja la reference A et ticket
il faut maintenant récupérer dans une variable le contenu de la plage partant de l'index jusque au suvant -1 de la colonne C on obtiens ainsi la colonne C en un seul morceau
on fait pareil pour la dolonne D
ensuite on recupere E,Fet G
et le tour est joué
voila la marche a suivre

a moins que certaine cellule soit fusionnées comme cela semble etre le cas pour B,C,E et G (je ne vois pas le gridline dans ces colonnes
dans ce cas la c'est encore un peu plus compliqué mais la il nous faut un classeur exemple avec au moins 2 ou 3 cas

http://www.developpez.net/forums/att...ong/forum.png/
24/08/2015, 11h44
MobyKDIK

1 pièce(s) jointe(s)

Je vous remercie de toutes vos réponses, je n'espérais pas autant d'aide !! :merci:

Je me lance dans la lecture de tout ce que vous m'avez proposé, mais avant je vous envoie un exemple excel des tableaux sur lesquels je travaille, j'ai essayé d'enlever des infos pour que le confidentiel soit respecté.
Encore merci !
Pièce jointe 186145
24/08/2015, 11h53
MobyKDIK

Alors de ce que j'ai lu de vos réponses, je crois que tu as mal compris mon problème Theze
Comme patricktoulon semble l'avoir vu, l'extraction que je fais depuis un autre logiciel va créer des lignes sur le tableau excel, et je n'aurais pas une cellule avec des sauts de lignes mais des cellules pour chaque saut de ligne ! C'est dur à expliquer à l'oral mais avec l'exemple que j'ai joint vous devriez comprendre ce que je peine à expliquer.

Effectivement patricktoulon j'ai construit ma macro telle qu'elle repère les indices de ligne de début et fin de chaque ticket (i.e. un numéro en INC), et va des lignes les plus basses vers les plus en haut en recopiant les données si il le faut des cellules du dessous vers celles du dessus.
Ma macro arrive à faire cela, mon problème n'est pas d'y arriver, mais d'y arriver plus vite !!
Ma macro est très lente, car je peux travailler avec des milliers de lignes !
Encore en vous remerciant !
Et sur ce, bon appétit :yaisse:
24/08/2015, 11h57
patricktoulon

re

donc j'avais bien compris
pour la rapidité utilise plutot des variables tableaux

et traville sur ls tableaux et repose le contenu
donne mois un exemple de ton fichier avec seulement 2 ou 3 ref meme bidon on s'en fou

Avec un exemple c'est un peu plus compréhensible !
Teste le code qui suit. Le résultat est inscrit dans la feuille "AprèsMacro" sans modification de la feuille "AvantMacro" :

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
 
Sub Test()
 
    Dim FeDest As Worksheet
    Dim FeSource As Worksheet
    Dim Plage As Range
    Dim Cel As Range
    Dim Adr As String
    Dim I As Integer
    Dim J As Long
    Dim Texte As String
 
    Set FeSource = Worksheets("AvantMacro") '<--adapter le nom de la feuille
 
    'la feuille "AprèsMacro" reçois les résultats
    Set FeDest = Worksheets("AprèsMacro")
 
    'défini la plage en colonne A (où se trouve les cellules fusionnées)
    With FeSource
 
        Set Plage = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp).MergeArea)
 
    End With
 
    J = 1
 
    Set Cel = Plage.Find("INC00*", , xlValues)
 
    If Not Cel Is Nothing Then
 
        Adr = Cel.Address
 
        Do
 
            J = J + 1
 
            'inscrit le code et la date
            FeDest.Cells(J, 1).Value = Cel.Value
            FeDest.Cells(J, 3).Value = Cel.Offset(, 3).Value
 
            'ici, indiquer l'état (il n'est pas préciser dans l'exemple)
            'Fe.Cells(J, 3).Value = Cel.Offset(, 4).Value '4 peut être ?
 
            'concatène les différentes valeurs de la plage correspondant à la plage fusionnée en colonne A
            For I = 0 To Cel.MergeArea.Count - 1
 
                FeDest.Cells(J, 2).Value = FeDest.Cells(J, 2).Value & " " & FeSource.Cells(Cel.Row + I, 3).Value
 
            Next I
 
            'recherche le suivant
            Set Cel = Plage.FindNext(Cel)
 
        Loop While Adr <> Cel.Address
 
    End If
 
End Sub

Hervé.

24/08/2015, 12h52
patricktoulon

re

theze
d'apres ce que j'ai compris il n'y a pas de cellules fusionnées c'est sa capture qui induit en erreur
24/08/2015, 13h00
MobyKDIK

Il y a quand même des cellules fusionnées sur mon tableau initial : quand il y a du texte, il sépare sur plusieurs cellules dès qu'il y a des espaces. Mais pour les infos simples sur les autres colonnes, il fait une fusion des cellules : sur les images que j'avais mis précédemment cela se voit : là où il y a des traits c'est qu'il y a plusieurs cellules, sinon c'est qu'elles sont fusionnées
Theze merci pour ton code j'essaye ça tout de suite
24/08/2015, 13h05
patricktoulon

re

oulah!!! mobydick je te cite

Citation:

Comme patricktoulon semble l'avoir vu, l'extraction que je fais depuis un autre logiciel va créer des lignes sur le tableau excel, et je n'aurais pas une cellule avec des sauts de lignes mais des cellules pour chaque saut de ligne !

bon je laisse theze s'en charger
bon courage
24/08/2015, 13h29
MobyKDIK

Désolé patricktoulon si je t'ai induit en erreur, je me suis mal exprimé, et le classeur que j'ai mis en pièce jointe dans un de mes précédents postes permettait de préciser mes explications assez obscures.
Je vais surement suivre ton conseil de toute manière, il me semble déjà avoir lu que VBA travaille bien mieux avec des variables construites qu'avec les cellules propres à une feuille.
Merci pour ton code Theze, avant même de parler de l'algo, cela m'apprend plusieurs nouvelles méthodes très intéressantes, je ne les connaissais pas du tout !
Sinon cela devrait marcher sans problème !
Merci beaucoup à vous 2 !

Bonjour,

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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
#If VBA7 Then
 Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
 Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As Long
 Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As LongPtr, ByVal dwBytes As LongPtr) As Long
 Private Declare PtrSafe Function CloseClipboard Lib "User32" () As Long
 Private Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hwnd As LongPtr) As Long
 Private Declare PtrSafe Function EmptyClipboard Lib "User32" () As Long
 Private Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
 Private Declare PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat As LongPtr, ByVal hMem As LongPtr) As Long
 Private Declare PtrSafe Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long
#Else
 Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
 Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
 Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
 Private Declare Function CloseClipboard Lib "User32" () As Long
 Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
 Private Declare Function EmptyClipboard Lib "User32" () As Long
 Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
 Private Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
 Private Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long
#End If
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
 
 
Sub test()
 
Dim txt As String
ThisWorkbook.Sheets("AvantMacro").Range("A1").CurrentRegion.Copy
txt = ClipBoard_GetData
 
Dim Sh As Worksheet
Set Sh = ThisWorkbook.Sheets.Add
ClipBoard_SetData txt
Sh.Paste
Dim R As Range
Set R = Sh.UsedRange
Dim I As Long
txt = ""
For I = R.Rows.Count To 2 Step -1
    txt = R(I, 3) & " " & Trim(txt)
    If Trim(R(I, 1)) <> "" Then
        R(I, 3) = txt: txt = ""
    Else
        R.Rows(I).Delete
    End If
 
Next
End Sub
Function ClipBoard_GetData() As String
   Dim hClipMemory As Long
   Dim lpClipMemory As Long
   Dim MyString As String
   Dim RetVal As Long
 
   If OpenClipboard(0&) = 0 Then
      MsgBox "Cannot open Clipboard. Another app. may have it open"
      Exit Function
   End If
 
   ' Obtain the handle to the global memory
   ' block that is referencing the text.
   hClipMemory = GetClipboardData(CF_TEXT)
   If IsNull(hClipMemory) Then
      MsgBox "Could not allocate memory"
      GoTo OutOfHere
   End If
 
   ' Lock Clipboard memory so we can reference
   ' the actual data string.
   lpClipMemory = GlobalLock(hClipMemory)
 
   If Not IsNull(lpClipMemory) Then
      MyString = Space$(MAXSIZE)
      RetVal = lstrcpy(MyString, lpClipMemory)
      RetVal = GlobalUnlock(hClipMemory)
 
      ' Peel off the null terminating character.
      MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)
   Else
      MsgBox "Could not lock memory to copy string from."
   End If
 
OutOfHere:
 
   RetVal = CloseClipboard()
   ClipBoard_GetData = MyString
 
End Function
Function ClipBoard_SetData(MyString As String)
   Dim hGlobalMemory As Long, lpGlobalMemory As Long
   Dim hClipMemory As Long, X As Long
 
   ' Allocate moveable global memory.
   '-------------------------------------------
   hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
 
   ' Lock the block to get a far pointer
   ' to this memory.
   lpGlobalMemory = GlobalLock(hGlobalMemory)
 
   ' Copy the string to this global memory.
   lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
 
   ' Unlock the memory.
   If GlobalUnlock(hGlobalMemory) <> 0 Then
      MsgBox "Could not unlock memory location. Copy aborted."
      GoTo OutOfHere2
   End If
 
   ' Open the Clipboard to copy data to.
   If OpenClipboard(0&) = 0 Then
      MsgBox "Could not open the Clipboard. Copy aborted."
      Exit Function
   End If
 
   ' Clear the Clipboard.
   X = EmptyClipboard()
 
   ' Copy the data to the Clipboard.
   hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
 
OutOfHere2:
 
   If CloseClipboard() = 0 Then
      MsgBox "Could not close Clipboard."
   End If
 
   End Function

24/08/2015, 15h26
Theze

Bonjour Patrick,

Dans le classeur posté, elles sont fusionnées en colonne A, B et D, sur la colonne C les différentes valeurs se trouvent dans différentes cellules d'où mon bouclage "For I = 0 To Cel.MergeArea.Count - 1".
Cependant, dans le résultat voulu, les informations concernant la colonne "Etat du Ticket" se trouvent nulle part !

Hervé.
24/08/2015, 15h40
patricktoulon

re

salut durupt :mouarf: oh! le pauvre !!
24/08/2015, 15h44
Invité

Citation:

Envoyé par patricktoulon

salut durupt :mouarf: oh! le pauvre !!

bonjour Patrick,
il n’empêche que ça marche!

je n'avais pas vu le fichier joint
dans ce cas la trop simple
au plus rapide en terme de reflection
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Option Base 1 Sub test() Dim tablo, tablofinal, i tablo = Sheets("AvantMacro").Range("A1:D22").Value ' reste a adapter le .end(xlup) For i = 1 To UBound(tablo) If tablo(i, 1) <> "" Then A = i: ind = ind + 1 If tablo(i, 1) = "" Then tablo(A, 3) = Replace(tablo(A, 3) & " " & tablo(i, 3), Chr(10), " "): tablo(i, 3) = "" End If Next With Sheets("AprèsMacro") .Cells(1, 1).Resize(UBound(tablo), 4) = tablo .UsedRange.SpecialCells(xlCellTypeBlanks).EntireRow.Delete End With End Sub
allez j'edit
pour la derlig

Code:

tablo = Sheets("AvantMacro").Range("A1:D" & Cells(Rows.Count, 3).End(xlUp).Row + 1).Value ' reste a adapter le .end(xlup)

et basta

24/08/2015, 16h22
Invité

c'est bien de corriger mon esprit tordu
24/08/2015, 16h31
patricktoulon

re

Citation:

Envoyé par rdurupt

bonjour Patrick,
il n’empêche que ça marche!

oui je suis d'accords avec toi mais dela a enclancher une usine a gaz pour un tableau a 4 colonnes hoh!! puré t'é trop fort :ptdr::ptdr:
:lefou::sm::fou::scarymov::pan:

Voir 40 message(s) de cette discussion en une page