Fill cell with a value from List Validation applied

Hello all,
I'm working on a macro that checks if list validation rule is applied to a cell and if it is empty, fill its content from one of the values available in the list.
I'm currently facing a problem that the setting of up of value is applied even if there is no list validation rule applied to it.
My sample data in a worksheet

Header
List validation rule Applied but empty
List validation rule Applied but empty
List validation rule Applied but empty
.
.
.
Header
List validation rule Applied but empty
List validation rule Applied but empty
List validation rule Applied but not empty
.
.
.

Header
List validation rule Applied but empty
List validation rule Applied but empty
List validation rule Applied but empty
.
.
.


The problem is even though list validation rule is not applied to headers, the value is applied to them. I would like to know a way to stop this.

Sub FillDefaults()
    'Open the selected workbooks and apply default values
    Dim currentSheet As Worksheet
    Dim cellRange As Range
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Show
        .Filters.Add "Excel 2003", "*.xls"
        .Filters.Add "Excel 2007", "*.xlsx"
        
        For counter = 1 To .SelectedItems.Count
            Workbooks.Open (.SelectedItems(counter))
            For Each currentSheet In ActiveWorkbook.Sheets
                'For every sheet, start from the cell with first test condition
                'If the cell is a test condition and a validation rule applied
                'then make the default choice to its status
                Dim cellCounter As Integer
                Dim cellValue As Variant
                Dim Rng As Range
                
                cellCounter = 2
                cellValue = currentSheet.Range("A" & cellCounter).Value
                
                Do While cellValue <> ""
                    'check if corrsponding test conditions's status has any
                    'list validation applied and apply default values
                    On Error Resume Next
                    Set Rng = Intersect(currentSheet.Range("B" & cellCounter), Cells.SpecialCells(xlCellTypeSameValidation))
                    On Error GoTo 0
                    If Rng Is Nothing Then
                       If currentSheet.Range("B" & cellCounter).Value = "" Then
                          currentSheet.Range("B" & cellCounter).Value = "In Progress"
                       End If
                    End If
                                        
                    cellCounter = cellCounter + 1
                    cellValue = currentSheet.Range("A" & cellCounter).Value
                Loop
            Next
            ActiveWorkbook.Save
            ActiveWorkbook.Close
        Next
    End With
End Sub

Sorry for cross posting. I'm marking this as solved as I've opened it on the other community mrexcel.

Don't crosspost!!!