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("D500750").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("P500750").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.
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("D500750").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("P500750").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
Dernière édition: