Help needed for old thread Please ??

[Les Stout]

Hi all, firstly i apologise for my placing this but i need an answer if
possible to my thread from Saturday listed below, as it is urgent...

Help needed with Complicated code (For me !!)

Thank you for any help in advance

Best regards,

Les Stout

 

[Bob Phillips]

Not listed Les, and can't see that old thread.

--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Guest]

You got an answer from Tom Ogilvy which is green ticked as having answered
the question and a further esponse from Martin Fishlock which was never
responded to so I guess posters have assumed that the green tick indicated
problem resolved.

Mike

 

[Guest]

Ok, this is my best guess:

Sub TestTom()
'
Dim todaysDateLong As String
Dim sh1 As Worksheet, sh2 As Worksheet
Dim sh6 As Worksheet
Dim rng1 As Range, rng2 As Range
Dim rng3 As Range
Dim rw As Long, cell As Range
Dim res As Variant

ActiveWorkbook.Worksheets("PU0703LCS").Rows("1:1").Copy
ActiveWorkbook.Worksheets.Add(Before:=ActiveSheet).Name = "LCS_KTL AI
Diff"
ActiveSheet.Paste

Set sh1 = Worksheets("PU0703LCS")
Set sh2 = Worksheets("KTL")
Set sh6 = Worksheets("LCS_KTL AI Diff")
rw = 2
Set rng1 = sh1.Range(sh1.Cells(2, 1), sh1.Cells(2, 1).End(xlDown))
Set rng2 = sh2.Range(sh2.Cells(2, 1), sh2.Cells(2, 1).End(xlDown))
For Each cell In rng1
If Application.CountIf(rng2, cell.Value) = 0 Then

Else
res = Application.Match(cell.Value, rng2, 0)
Set rng3 = rng2(res)
If cell.Offset(0, 1) > sh2.Cells(rng3.Row, "J") Then
cell.EntireRow.Copy sh6.Cells(rw, 1)
rw = rw + 1
End If
End If
Next

Range("A1").Select
Columns("A:O").EntireColumn.AutoFit
End Sub

It copies about 4 records.