Code works but goes into endless loop and crashes

[Howard]

Looks up a number from sheet 1, Column A in Sheet 2 Column E, and posts offsets from both the left and right of that Col E number back to Column A.

Once the post has been completed the worksheet/book freezes and offers a not responding massage. Restart of Excel is required.

The commented out code works okay until a Column A number does not exist in Sheet 2 Column E, and the posts back to sheet 1 are posted wrong because of the .End(xlUp)(2).

Thanks.
Howard

Option Explicit

Sub ListNewPN()

Dim rngPN As Range
Dim c As Range, i As Range
Dim ws1Part_Num As Range
Dim ws2From_Item As Range

Set ws1Part_Num = Sheets("Sheet1"). _
Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)

Set ws2From_Item = Sheets("Sheet2"). _
Range("E1:E" & Range("E" & Rows.Count).End(xlUp).Row)

For Each c In ws1Part_Num

Set rngPN = ws2From_Item.Find(c, LookIn:=xlValues, _
lookat:=xlWhole)

If Not rngPN Is Nothing Then

For Each i In ws1Part_Num

If i = rngPN Then
i.Offset(0, 1) = rngPN.End(xlToRight)
i.Offset(0, 2) = rngPN.End(xlToLeft)
End If

'Sheets("Sheet1").Range("B100").End(xlUp)(2) _
= rngPN.End(xlToRight)

'Sheets("Sheet1").Range("C100").End(xlUp)(2) _
= rngPN.End(xlToLeft)

Next
End If
Next

End Sub

 

[Claus Busch]

Hi Howard,

Am Mon, 7 Oct 2013 10:09:08 -0700 (PDT) schrieb Howard:

Looks up a number from sheet 1, Column A in Sheet 2 Column E, and posts offsets from both the left and right of that Col E number back to Column A.

Once the post has been completed the worksheet/book freezes and offers a not responding massage. Restart of Excel is required.

I hope I understood your problem.
Try:

Sub ListNewPN()

Dim rngPN As Range
Dim c As Range
Dim ws1Part_Num As Range
Dim ws2From_Item As Range
Dim firstaddress As String
Dim LRow1 As Long
Dim LRow2 As Long

With Sheets("Sheet1")
LRow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
Set ws1Part_Num = .Range("A1:A" & LRow1)
End With

With Sheets("Sheet2")
LRow2 = .Cells(.Rows.Count, 5).End(xlUp).Row
Set ws2From_Item = .Range("E1:E" & LRow2)


For Each c In ws1Part_Num
Set rngPN = ws2From_Item.Find(c, LookIn:=xlValues, _
lookat:=xlWhole)

If Not rngPN Is Nothing Then
Do
firstaddress = c.Address
c.Offset(0, 1) = rngPN.Offset(, -1)
c.Offset(0, 2) = rngPN.Offset(, 1)
Set rngPN = ws2From_Item.FindNext(rngPN)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
Next c
End With
End Sub


Regards
Claus B.