[RESOLU] Amélioration de la macro

[red-69]

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. 😱
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😀750").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😛750").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.

 

[Softmama]

Re : Amélioration de la macro

Bonjour,

A tester, mais je dirais comme ceci :

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]

 

[Softmama]

Re : Amélioration de la macro

Et pour l'accélérer, je dirais :

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.

 

[red-69]

Re : Amélioration de la macro

Merci pour cette réponse.

Je viens de tester et cela m'indique une erreur de compilation/synthaxe au niveau de la ligne :

Range("A500:A750").(1,t).SpecialCells(xlCellTypeBlanks). Delete xlUp

 

[Softmama]

Re : Amélioration de la macro

re,

Enlève les espaces superflus (dans . Delete et Bl anks )

 

[Softmama]

Re : Amélioration de la macro

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

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]

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]

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]

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

 

[Softmama]

Re : Amélioration de la macro

houlà, c'est pas bien logique ça. Je vais tester mon code et reviens te dire ce que ça m'a fait. A toute.

 

[Softmama]

Re : Amélioration de la macro

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

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

 

[red-69]

Re : Amélioration de la macro

Effectivement, ca fonctionne beaucoup mieux.

Un grand merci à toi Softmama

 

[PMO2]

Re : Amélioration de la macro

Bonjour,

Essayez avec le code suivant

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