Boucler une action sur un range

[Delux]

Bonjour a tous,

Je souhaiterais creer une macro qui va boucler une action sur un range variable.
Mon range peut s'etendre de A3:C4 a A3:AZ65000.

Je n'arrive pas a dire a la macro de boucler jusqu'a la derniere cellule de la derniere colonne remplie (qui peut aller jusqu'a AZ).

Dans ce range variable, il faut que si la cellule est jaune est si la valeur est "X" (Import Sheet) alors on insere dans le deuxieme tableau (Check sheet, identique mais sans les information du premier) une formule.

Voici le debut de la macro que j'ai ecrit:

Sub DST_Attributes_Check2()
'Check Attributes

Dim mySource As Range
Dim myCible As Range
Dim Cel As Range
Dim Lg As Integer

Application.ScreenUpdating = False

Set mySource = Sheet17.Range("A4.A" & [A65489].End(xlUp).Row)
Set myCible = Sheet18.Range("C4:AZ" & [C65489].End(xlUp).Row)
Lg = 4

myCible.ClearContents

For Each Cel In mySource
    If Cel.Value <> "" Then
        
        Sheet18.Range("C" & Lg).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$2929, 3, 0)<>"""", 1, 0)"
        Sheet18.Range("D" & Lg).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$2929, 3, 0)<>"""", 1, 0)"
        Sheet18.Range("E" & Lg).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$2929, 3, 0)<>"""", 1, 0)"
        Sheet18.Range("F" & Lg).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$2929, 3, 0)<>"""", 1, 0)"
        Sheet18.Range("G" & Lg).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$2929, 3, 0)<>"""", 1, 0)"
        Sheet18.Range("H" & Lg).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$2929, 3, 0)<>"""", 1, 0)"
        Sheet18.Range("I" & Lg).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$2929, 3, 0)<>"""", 1, 0)"
        Sheet18.Range("J" & Lg).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$2929, 3, 0)<>"""", 1, 0)"
        Sheet18.Range("K" & Lg).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$2929, 3, 0)<>"""", 1, 0)"
        Sheet18.Range("L" & Lg).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$2929, 3, 0)<>"""", 1, 0)"
        Sheet18.Range("M" & Lg).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$2929, 3, 0)<>"""", 1, 0)"
        Sheet18.Range("N" & Lg).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$2929, 3, 0)<>"""", 1, 0)"
        Sheet18.Range("O" & Lg).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$2929, 3, 0)<>"""", 1, 0)"
        Sheet18.Range("P" & Lg).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$2929, 3, 0)<>"""", 1, 0)"
        Sheet18.Range("Q" & Lg).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$2929, 3, 0)<>"""", 1, 0)"
        Sheet18.Range("R" & Lg).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$2929, 3, 0)<>"""", 1, 0)"
        Sheet18.Range("S" & Lg).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$2929, 3, 0)<>"""", 1, 0)"
        Sheet18.Range("T" & Lg).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$2929, 3, 0)<>"""", 1, 0)"
        
        'ainsi de suite jusqu'a AZ
 
        Lg = Lg + 1
    End If
  Next Cel
End Sub

Malheureusement, de cette facon la macro insere la formule meme dans les colonnes vides.

Je vous joints un petit exemple.

En vous remerciant par avance.

Cordialement,

Delux

 

[Abel]

Re : Boucler une action sur un range

Bonjour Delux,

Essaie ce code :
Sub DST_Attributes_Check2()

Dim mySource As Range
Dim myCible As Range
Dim Cel As Range
Dim Lg As Integer
Dim dl As Integer
Dim dc As Byte


Application.ScreenUpdating = False
dl = Sheet17.Range("A65489").End(xlUp).Row
dc = Sheet17.Range("iv4").End(xlToLeft).Column

Set mySource = Sheet17.Range(Cells(4, 3), Cells(dl, dc))
Set myCible = Sheet18.Range("C4:AZ" & [C65489].End(xlUp).Row)

myCible.ClearContents

For Each Cel In mySource
If Cel.Value <> "" Then
Sheet18.Cells(Cel.Row, Cel.Column).Formula = "=IF(VLOOKUP(A" & Cel.Row & ", 'IMPORT SHEET'!$A$4:$AZ$" & dl & ", 3, 0)<>"""", 1, 0)"
End If
Next Cel
End Sub

Abel.

 

[Abel]

Re : Boucler une action sur un range

Re,

Plus propre avec des balises :

Sub DST_Attributes_Check2()

Dim mySource As Range
Dim myCible As Range
Dim Cel As Range
Dim Lg As Integer
Dim dl As Integer
Dim dc As Byte


Application.ScreenUpdating = False
dl = Sheet17.Range("A65489").End(xlUp).Row
dc = Sheet17.Range("iv4").End(xlToLeft).Column

Set mySource = Sheet17.Range(Cells(4, 3), Cells(dl, dc))
Set myCible = Sheet18.Range("C4:AZ" & [C65489].End(xlUp).Row)

myCible.ClearContents

For Each Cel In mySource
    If Cel.Value <> "" Then
        Sheet18.Cells(Cel.Row, Cel.Column).Formula = "=IF(VLOOKUP(A" & Cel.Row & _
            ", 'IMPORT SHEET'!$A$4:$AZ$" & dl & ", 3, 0)<>"""", 1, 0)"
    End If
Next Cel
End Sub

Abel.

 

[Delux]

RESOLU - Boucler une action sur un range

Bonjour Abdel,

Merci pour ta reponse.

Ceci fonctionne a merveille.

Cependant, et c'est ma faute car je ne l'ai pas mis dans mon code, il fallait aussi que le "3" de la formule (Vlookup) corresponde au numero de la colonne dans laquelle la formule se trouve :

Sheet18.Cells(Cel.Row, Cel.Column).Formula = "=IF(VLOOKUP(A" & Cel.Row & _
            ", 'IMPORT SHEET'!$A$4:$AZ$" & dl & ", 3, 0)<>"""", 1, 0)"

exemple: C = 3, D = 4, E = 5, etc ...

juste a rajour

" & Cel.Column & "

Ce qui nous donne :

Sub DST_Attributes_Check2()

Dim mySource As Range
Dim myCible As Range
Dim Cel As Range
Dim Lg As Integer
Dim dl As Integer
Dim dc As Byte

Application.ScreenUpdating = False

Sheet17.Select

dl = Sheet17.Range("A65489").End(xlUp).Row
dc = Sheet17.Range("iv4").End(xlToLeft).Column

Set mySource = Sheet17.Range(Cells(4, 3), Cells(dl, dc))
Set myCible = Sheet18.Range("C4:AZ" & [C65489].End(xlUp).Row)

myCible.ClearContents

For Each Cel In mySource
    If Cel.Interior.ColorIndex = 6 Then
        Sheet18.Cells(Cel.Row, Cel.Column).Formula = "=IF(VLOOKUP(A" & Cel.Row & _
            ", 'IMPORT SHEET'!$A$4:$AZ$" & dl & ", " & Cel.Column & ", 0)<>"""", 1, 0)"
    End If
Next Cel

Sheet18.Select

End Sub

Encore merci.

Cordialement,

Delux