Code only looping through cells in first row of the range

[Matt888]

Hi,

The following code is intended to apply a formula to each cell in a defined range, then paste as values, then loop through each cell in the range twice to do 2 things:-

1. clear the contents of any cells where the formula result was "" - this loop work perfectly
2. for each non empty cell, if it equals the next non empty cell to the right then select the range between both non empty cells and apply fill color. Then clear the contents of the matching non empty cell to the right. - this loop only works for the first row in my range

Any help getting that 2nd loop to work would be greatly appreciated. Code below:-

Sub CalcCalendar()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim rng As Range: Set rng = Range("Calendar_Range")
Dim cel As Range

Sheets("Calendar").Select
rng.UnMerge
Range("C7").Formula = "=IFERROR(XLOOKUP($B7&C$1,Prod_Range&Start_Date_Range,Desc_Range),IFERROR(XLOOKUP($B7&C$1,Prod_Range&End_Date_Range,Desc_Range),""""))"
Range("C7").Copy Destination:=rng
rng.Copy
rng.PasteSpecial xlPasteValues

For Each cel In rng.Cells
If cel = "" Then
cel.ClearContents
End If
Next cel

For Each cel In rng.Cells
If cel <> "" And cel.Value = Selection.End(xlToRight).Value Then
cel.Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Interior.Color = 65535
cel.Select
Selection.End(xlToRight).Select
Selection.ClearContents
cel.Select
End If
Next cel

Range("C1").Select

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

 

[Alex Blakenburg]

I am not convinced the code is going to do what you are trying to do and we would not normally use "Select" in the code but in terms of your immediate issue add the line in Blue into your code.

Set rng = Range("A3:D6")
For Each cel In rng.Cells
    cel.Select
    If cel <> "" And cel.Value = Selection.End(xlToRight).Value Then

 

[Matt888]

I am not convinced the code is going to do what you are trying to do and we would not normally use "Select" in the code but in terms of your immediate issue add the line in Blue into your code.

Set rng = Range("A3:D6")
For Each cel In rng.Cells
    cel.Select
    If cel <> "" And cel.Value = Selection.End(xlToRight).Value Then

Thanks. I know it's a bit unconventional but seems such a simple thing I'm trying to achieve. Your correction actually seems to have done the trick. thanks for your help

 

[Alex Blakenburg]

Thanks for letting me know. Glad I could help.