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.

Hi,

With 35 posts you really should know the rules about embedding code between Code tags.

Please correct.

Rgds

Hi,

It would be easier to advise with certainty if we had the actual workbook since the loop exit condition in the line below is clearly never being met.

  Do While (Cells(currentRow, 2) <> "Issues/Risks Log")

Try stepping through the macro to observe why the Do never encounters a value in the 2nd (presumably B) column which is not equal to "Issues/Risks Log"

For instance are the 'Issues/Risks Log' in a different case perhaps, spelled differently or perhaps have a leading/trailing space?

If you can't debug it, upload the workbook, anonymised if necessary and limited to a representative sample of rows if there are hundreds of them.

Regards
Rgds

Hi

In your Case Else statement you are resetting the currentRow variable in the 2nd line to the value 28 i.e.

Case Else
                        Set rFindw = ActiveSheet.UsedRange.Find("Program Id", LookIn:=xlValues, lookat:=xlWhole)
                        currentRow = rFindw.Row + 1

So even though you are adding +1 at the end of the Else statement the currentrow variable never reaches the value 37 which is the Loop exit condition.

Rgds

Hi,

Commenting out that line seems to work fine on the copy I have. The currentrow variable processes until it reaches the value 37 where it exits the Do..Loop and goes on to the next Worksheet if there are any.

What makes you think it's not working? Have you tried stepping through it line by line to observe what happens?

Regards