Incorrect For-Each loop of visible cells after applying filter

Question

I am trying to select a range of visible cells after applying filter oCel. It is working just fine, when the data has more than 1 row however if there is only one visible row then it selects the entire sheet as range and start looping through each cell.

I have trying several methods to solve this problem but somehow I could not get what is going wrong here. I need to make it as simple as possible.

With im_SH
    .Range("1:1").AutoFilter Field:=.Range("B1").Column, Criteria1:=oCel
    For Each mCel In .Range("U2:U" & .Range("U" & .Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
            If db_SH.Cells(dr, "E") = "" Then
                db_SH.Cells(dr, "E") = mCel.Offset(0, -4)
            Else
            
                db_SH.Cells(dr, "E") = db_SH.Cells(dr, "E") & ", " & mCel.Offset(0, -4)
            
            End If
            
    Next mCel
End With

Working Update: Following is working VBA code, although, I don't want to add more IF conditions, I am not satisfied with this solution. Maybe, there is more robust and easier way to handle this particular situation.

Dim myR As Range
With im_SH
    .Range("1:1").AutoFilter Field:=.Range("B1").Column, Criteria1:=oCel
    Set myR = .Range("U2:U" & .Range("U" & .Rows.Count).End(xlUp).Row)
    
    If myR.Row = 1 Then GoTo eJump
    
    If myR.Cells.Count = 1 Then
    
        db_SH.Cells(dr, "E") = myR.Offset(0, -4)
    
    Else
    
        For Each mCel In myR.SpecialCells(xlCellTypeVisible)
            If db_SH.Cells(dr, "E") = "" Then
                db_SH.Cells(dr, "E") = mCel.Offset(0, -4)
            Else
                db_SH.Cells(dr, "E") = db_SH.Cells(dr, "E") & ", " & mCel.Offset(0, -4)
            End If
        Next mCel
    
    End If
eJump:

End With

Answer 1

Looping Through Elements of Array Instead Through Cells of Range

• IMO it's a too simple task to use AutoFilter. Of course, we don't know what's before and after the posted code.
• Not tested!

Sub Test()
    
    ' Previous Code...?
    
    ' Previously set in the code.
    Dim im_SH As Worksheet
    Dim oCel As Range
    
    ' Store the criteria string in a variable ('Criterion').
    
    Dim Criterion As String: Criterion = CStr(oCel.Value)
    
    ' Write the values (strings) from the columns ('lrg', 'srg', 'drg')
    ' to 2D one-based single-column arrays ('lData', 'sData', 'dData').
    
    ' Lookup (Criteria)
    Dim lrg As Range
    With im_SH
        ' Remove filters.
        If .FilterMode Then .ShowAllData
        ' Not sure about the significance of "U"!?,...
        Set lrg = .Range("B2", _
            .Cells(.Cells(.Rows.Count, "U").End(xlUp).Row, "B"))
        ' ... maybe you should consider this instead:
        'Set lrg = .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
    End With
    Dim rCount As Long: rCount = lrg.Rows.Count
    Dim lData() As Variant: lData = lrg.Value
    ' Source
    Dim srg As Range: Set srg = lrg.EntireRow.Columns("Q")
    Dim sData() As Variant: sData = srg.Value
    ' Destination
    Dim drg As Range: Set drg = lrg.EntireRow.Columns("E")
    Dim dData() As Variant: dData = drg.Value
    
    ' Read the values in the lookup and source arrays, and applying
    ' the required logic i.e. looking for criterion in 'B' to append 'Q' to 'E',
    ' to modify the values (strings) in the destination array.
    
    Dim r As Long
    Dim lString As String
    Dim sString As String
    Dim dString As String
    
    For r = 1 To rCount
        lString = CStr(lData(r, 1))
        If StrComp(lString, Criterion, vbTextCompare) = 0 Then ' () is equal ()
            sString = CStr(sData(r, 1))
            If Len(sString) > 0 Then ' source cell is not blank
                dString = CStr(dData(r, 1))
                If Len(dString) = 0 Then ' destination cell is blank
                    dString = sString
                Else ' destination cell is not blank
                    dString = dString & ", " & sString ' join (append)
                End If
                dData(r, 1) = dString
            'Else ' source cell is blank; do nothing
            End If
        'Else ' (lookup string) is not equal (to the criterion); do nothing
        End If
    Next r
               
    ' Write the values from the destination array back to the destination range.
               
    drg.Value = dData

    ' Following Code...?

End Sub