Infinite Loop

hello all...

i'm trying to loop through a bunch of worksheets and copy certain cells and paste it in a master sheet.

Please take a look at my code below because it keeps copying the same thing over and over and is stuck in an infinite loop.

For Each ws In ActiveWorkbook.Worksheets
    
    If ws.Visible = True Then
        ws.Activate

        Set rFind = Cells.Find(What:="Critical Activities / Watch List Items / and Milestones for Next 3 Months", After:=[A1], _
                                LookIn:=xlValues, _
                                lookat:=xlPart, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlNext, _
                                MatchCase:=False, _
                                SearchFormat:=False)
        If Not rFind Is Nothing Then
        'if it's the first sheet, copy the column headers, if not skip the headers
            If ActiveSheet.name = "A1 Replace Citichecking" Then
                currentRow = rFind.Row + 1
            Else
                currentRow = rFind.Row + 2
            End If
            'copy all rows until empty line, insert date and name
            'Do While Not IsEmpty(Cells(currentRow, 2))
            Do While (Cells(currentRow, 2) <> "Issues/Risks Log")
                Select Case Cells(currentRow, 2)
                    Case Is = ""
                        currentRow = currentRow + 1
                    Case Is = "Major Milestones to Program End Date Beyond Current 3 Month Cycle (Maximum 10 Items)"
                        currentRow = currentRow + 1
                    Case Is = "26. Responsible Area / Owner"
                        currentRow = currentRow + 1
                    Case Else
                        Set rFindw = ActiveSheet.UsedRange.Find("Program Id", LookIn:=xlValues, lookat:=xlWhole)
                        currentRow = rFindw.Row + 1
                        strprogID = Range("K" & currentRow).Value
                        strcritical = "BCM"
                        strMileName = Range("C" & currentRow).Value
                        strMileStatus = Range("I" & currentRow).Value
                        strReason = Range("M" & currentRow).Value
                        strDescr = Range("D" & currentRow).Value
                        dtOrig = Range("G" & currentRow).Value
                        dtActual = Range("H" & currentRow).Value
                        strCommit = Range("L" & currentRow).Value
                        strMileCmmt = Range("N" & currentRow).Value
                        strRemCmmt = Range("O" & currentRow).Value
                        
                            If rFindw Is Nothing Then
                                MsgBox "Not Found"
                                Exit Sub
                            End If
                        dest.Range("A" & cursor).Value = strprogID
                        dest.Range("B" & cursor).Value = strcritical
                        dest.Range("C" & cursor).Value = strMileName
                        dest.Range("D" & cursor).Value = strMileStatus
                        dest.Range("E" & cursor).Value = strReason
                        dest.Range("F" & cursor).Value = strDescr
                        'dest.Range("F" & cursor).EntireColumn.WrapText = True
                        dest.Range("G" & cursor).Value = dtOrig
                        dest.Range("H" & cursor).Value = dtActual
                        dest.Range("I" & cursor).Value = strCommit
                        dest.Range("J" & cursor).Value = strMileCmmt
                        dest.Range("K" & cursor).Value = strRemCmmt
                        dest.Range("L" & cursor).Value = ActiveSheet.name
                        dest.Range("M" & cursor).Value = name
                        dest.Range("N" & cursor).Value = addDate
                                                
                        
                        cursor = cursor + 1
                        currentRow = currentRow + 1
                    End Select
            Loop

        End If
    End If
Next ws


Worksheets("BCMs").Select
'Delete columns GH in destination worksheet to fix merge issue
Columns("G:H").Delete Shift:=xlToLeft
Columns("J").Delete (xlToLeft)

Thank you.