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

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.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

Hi Howard,

Am Mon, 7 Oct 2013 19:48:05 +0200 schrieb Claus Busch:

sorry, there is an error into the code. 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 = rngPN.Address
c.Offset(0, 1) = rngPN.Offset(, -1)
c.Offset(0, 2) = rngPN.Offset(, 1)
Set rngPN = ws2From_Item.FindNext(rngPN)
Loop While Not rngPN Is Nothing And rngPN.Address < firstaddress
End If
Next c
End With
End Sub



Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

On Monday, October 7, 2013 10:53:00 AM UTC-7, Claus Busch wrote:
Hi Howard,



Am Mon, 7 Oct 2013 19:48:05 +0200 schrieb Claus Busch:



sorry, there is an error into the code. 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 = rngPN.Address

c.Offset(0, 1) = rngPN.Offset(, -1)

c.Offset(0, 2) = rngPN.Offset(, 1)

Set rngPN = ws2From_Item.FindNext(rngPN)

Loop While Not rngPN Is Nothing And rngPN.Address < firstaddress

End If

Next c

End With

End Sub

Regards

Claus B.



Hi Claus,

Here is a link to my workbook.

https://www.dropbox.com/s/zlqt546kno...rop%20Box.xlsm

Am getting a freeze up with you code also.
See sheet 1, has a few words about what the results should be.

Basically if the number in col A sheet 1 is found in sheet 2 col E, then an offset to the left and to the right of that found number is posted in col B & C on sheet 1.

The 123 & 456 numbers in col A sheet 1 are not in col E of sheet 2, so their returns should be "" (Blank).

Thanks.
Howard

Hi Howard,

Am Mon, 7 Oct 2013 11:49:39 -0700 (PDT) schrieb Howard:

https://www.dropbox.com/s/zlqt546kno...rop%20Box.xlsm

Am getting a freeze up with you code also.
See sheet 1, has a few words about what the results should be.

please have a look:
https://skydrive.live.com/#cid=9378A...121822A3%21326
for workbook "Master & MSA"
The button and my code works
(Procedures has to be placed in a standard module)



Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

On Monday, October 7, 2013 12:12:56 PM UTC-7, Claus Busch wrote:
Hi Howard,



Am Mon, 7 Oct 2013 11:49:39 -0700 (PDT) schrieb Howard:



https://www.dropbox.com/s/zlqt546kno...rop%20Box.xlsm



Am getting a freeze up with you code also.

See sheet 1, has a few words about what the results should be.



please have a look:

https://skydrive.live.com/#cid=9378A...121822A3%21326

for workbook "Master & MSA"

The button and my code works

(Procedures has to be placed in a standard module)

Regards

Claus B.

Yes, it does indeed!

Works with blanks, non match numbers and blanks.

Always impressed, and even more grateful.

Thanks,
Howard