[RESOLU] Amélioration de la macro

red-69

XLDnaute Nouveau
Bonjour à tous.
J'ai créé une macro dont le résultat correspond à mes attentes.
En revanche, elle est assez longue à s'effectuer.
Je pense que cela est dû au fait qu'il y a moyen d'améliorer cette macro. A l'heure actuelle je pense qu'elle n'est pas encore assez efficace.
Elle a pour but de copier dans chaque colonne de A à AA toutes les cellules qui contiennent un code spécial ('A'). Une fois ce code repéré, elle copie la cellule concernée plus bas dans le tableau (494 cellules plus bas).

J'aimerai avoir un coup de main si possible. J'imagine qu'il y a moyen d'utiliser une boucle, mais j'avoue ne pas maitriser assez le sujet. :eek:
Voici la macro :

Sub Action()
Dim x As Integer
Dim Mavaleur

Range("A500:AA750").ClearContents 'efface le contenu des cellules


'La variable x va successivement prendre les valeurs 3 à 10
For x = 6 To 250
If (Cells(x, 1).Value) Like "*'A'*" Then Cells(x + 494, 1).Value = Cells(x, 1)
Next x
Range("A500:A750").SpecialCells(xlCellTypeBlanks).Delete xlUp 'supprimer cellules vides de colonne A sans toucher les autres colonnes

For x = 6 To 250
If (Cells(x, 2).Value) Like "*'A'*" Then Cells(x + 494, 2).Value = Cells(x, 2)
Next x
Range("B500:B750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 3).Value) Like "*'A'*" Then Cells(x + 494, 3).Value = Cells(x, 3)
Next x
Range("C500:C750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 4).Value) Like "*'A'*" Then Cells(x + 494, 4).Value = Cells(x, 4)
Next x
Range("D500:D750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 5).Value) Like "*'A'*" Then Cells(x + 494, 5).Value = Cells(x, 5)
Next x
Range("E500:E750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 6).Value) Like "*'A'*" Then Cells(x + 494, 6).Value = Cells(x, 6)
Next x
Range("F500:F750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 7).Value) Like "*'A'*" Then Cells(x + 494, 7).Value = Cells(x, 7)
Next x
Range("G500:G750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 8).Value) Like "*'A'*" Then Cells(x + 494, 8).Value = Cells(x, 8)
Next x
Range("H500:H750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 9).Value) Like "*'A'*" Then Cells(x + 494, 9).Value = Cells(x, 9)
Next x
Range("I500:I750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 10).Value) Like "*'A'*" Then Cells(x + 494, 10).Value = Cells(x, 10)
Next x
Range("J500:J750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 11).Value) Like "*'A'*" Then Cells(x + 494, 11).Value = Cells(x, 11)
Next x
Range("K500:K750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 12).Value) Like "*'A'*" Then Cells(x + 494, 12).Value = Cells(x, 12)
Next x
Range("L500:L750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 13).Value) Like "*'A'*" Then Cells(x + 494, 13).Value = Cells(x, 13)
Next x
Range("M500:M750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 14).Value) Like "*'A'*" Then Cells(x + 494, 14).Value = Cells(x, 14)
Next x
Range("N500:N750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 15).Value) Like "*'A'*" Then Cells(x + 494, 15).Value = Cells(x, 15)
Next x
Range("O500:O750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 16).Value) Like "*'A'*" Then Cells(x + 494, 16).Value = Cells(x, 16)
Next x
Range("P500:p750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 17).Value) Like "*'A'*" Then Cells(x + 494, 17).Value = Cells(x, 17)
Next x
Range("Q500:Q750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 18).Value) Like "*'A'*" Then Cells(x + 494, 18).Value = Cells(x, 18)
Next x
Range("R500:R750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 19).Value) Like "*'A'*" Then Cells(x + 494, 19).Value = Cells(x, 19)
Next x
Range("S500:S750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 20).Value) Like "*'A'*" Then Cells(x + 494, 20).Value = Cells(x, 20)
Next x
Range("T500:T750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 21).Value) Like "*'A'*" Then Cells(x + 494, 21).Value = Cells(x, 21)
Next x
Range("U500:U750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 22).Value) Like "*'A'*" Then Cells(x + 494, 22).Value = Cells(x, 22)
Next x
Range("V500:V750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 23).Value) Like "*'A'*" Then Cells(x + 494, 23).Value = Cells(x, 23)
Next x
Range("W500:W750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 24).Value) Like "*'A'*" Then Cells(x + 494, 24).Value = Cells(x, 24)
Next x
Range("X500:X750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 25).Value) Like "*'A'*" Then Cells(x + 494, 25).Value = Cells(x, 25)
Next x
Range("Y500:Y750").SpecialCells(xlCellTypeBlanks).Delete xlUp

For x = 6 To 250
If (Cells(x, 26).Value) Like "*'A'*" Then Cells(x + 494, 26).Value = Cells(x, 26)
Next x
Range("Z500:Z750").SpecialCells(xlCellTypeBlanks).Delete xlUp


End Sub


Merci à vous.
 

Pièces jointes

  • Exemple macro.xlsm
    28 KB · Affichages: 64
  • Exemple macro.xlsm
    28 KB · Affichages: 65
  • Exemple macro.xlsm
    28 KB · Affichages: 68
Dernière édition:

Softmama

XLDnaute Accro
Re : Amélioration de la macro

Bonjour,

A tester, mais je dirais comme ceci :

Code:
Sub Action()
Dim x As Integer[B], t as integer [/B]
Dim Mavaleur

Range("A500:AA750").ClearContents 'efface le contenu des cellules


'La variable x va successivement prendre les valeurs 3 à 10
[B]For t=1 to 26[/B]
For x = 6 To 250
If (Cells(x, [B]t[/B]).Value) Like "*'A'*" Then Cells(x + 494, [B]t[/B]).Value = Cells(x, [B]t[/B])
Next x
Range("A500:A750")[B].(1,t)[/B].SpecialCells(xlCellTypeBlanks). Delete xlUp 
[B]next t[/B]
 
Dernière édition:

Softmama

XLDnaute Accro
Re : Amélioration de la macro

Et pour l'accélérer, je dirais :
Code:
Sub Action()
Dim t as integer

Range("A500:AA750").ClearContents 

For t=1 to 26
  For each cell in range("A6:A256").(1,t).specialcells(xlcelltypeconstants,23)
    If cell Like "*'A'*" Then cell.(495,1) = cell
  Next 
Range("A500:A750").(1,t).SpecialCells(xlCellTypeBlanks).Delete xlUp 
next t

A tester, si ça marche pas, joins un extrait de ton classeur qu'on travaille pas dans le vide.
 
Dernière édition:

Softmama

XLDnaute Accro
Re : Amélioration de la macro

re,
dsl j'ai trompé , faut enlever tous les points avt les références , comme suit :

Code:
Sub Action()
Dim t as integer

Range("A500:AA750").ClearContents 

For t=1 to 26
  For each cell in range("A6:A256")(1,t).specialcells(xlcelltypeconstants,23)
    If cell Like "*'A'*" Then cell(495,1) = cell
  Next 
Range("A500:A750")(1,t).SpecialCells(xlCellTypeBlanks).Delete xlUp 
next t
 

red-69

XLDnaute Nouveau
Re : Amélioration de la macro

Je viens d'enlever les blancs.
Voici une nouvelle erreur :

attendu identificateur ou expression entre crochet

Cela en surlignant à chaque fois la parenthèse après le point pour ces trois lignes :

For each cell in range("A6:A256").(1,t).specialcells(xlcelltypeconstants,23)

If cell Like "*'A'*" Then cell.(495,1) = cell
Range("A500:A750").(1,t).SpecialCells(xlCellTypeBlanks).Delete xlUp
 

Softmama

XLDnaute Accro
Re : Amélioration de la macro

Oui je me suis rendu compte de mon erreur, ds le post précédent, faut juste virer les points que j'ai mis par erreur :)
Je viens d'enlever les blancs.
Voici une nouvelle erreur :

attendu identificateur ou expression entre crochet

Cela en surlignant à chaque fois la parenthèse après le point pour ces trois lignes :

For each cell in range("A6:A256").(1,t).specialcells(xlcelltypeconstants,23)

If cell Like "*'A'*" Then cell.(495,1) = cell
Range("A500:A750").(1,t).SpecialCells(xlCellTypeBlanks).Delete xlUp
 

red-69

XLDnaute Nouveau
Re : Amélioration de la macro

Il doit y avoir une erreur encore, car pour l'instant la macro tourne sans s'arrêter et me copie toutes les cellules contenant 'A' à partir de la cellule A1 jusqu'à la ligne 10590.
Merci du coup de main
 
Dernière édition:

Softmama

XLDnaute Accro
Re : Amélioration de la macro

Re, en effet, ça collait paqs,je suis repassé par les .offset qui permettent de fonctionner :

Code:
Sub Action()
Dim t As Integer
On Error Resume Next
Range("A500:AA750").ClearContents

For t = 1 To 26
  For Each cell In Range("A6:A256").Offset(0, t -1).SpecialCells(xlCellTypeConstants, 23)
    If cell Like "*'A'*" Then cell.Offset(494, 0) = cell
  Next
Range("A500:A750").Offset(0, t - 1).SpecialCells(xlCellTypeBlanks).Delete xlUp
Next t
End Sub
 

PMO2

XLDnaute Accro
Re : Amélioration de la macro

Bonjour,

Essayez avec le code suivant

Code:
Sub Action_pmo()
Dim R1 As Range
Dim R2 As Range
Dim var
Dim i&
Dim j&
Set R1 = ActiveSheet.[a6].CurrentRegion
Set R2 = R1.Offset(494, 0)
var = R1
For i& = 1 To UBound(var, 1)
  For j& = 1 To UBound(var, 2)
    If InStr(1, var(i&, j&), "'A'") = 0 Then
      var(i&, j&) = ""
    End If
  Next j&
Next i&
R1.Copy
R2.PasteSpecial xlPasteAll
R2 = var
Application.CutCopyMode = False
End Sub

Je joins un exemple sous Excel2003.

Cordialement.

PMO
Patrick Morange
 

Statistiques des forums

Discussions
299 706
Messages
1 978 624
Membres
206 311
dernier inscrit
koumb