Help needed with Complicated code (For me !!)

[Guest]

Hi all, i have the code below which i got off a site. I have changed it to
suit me but i need help with the second part.. I have put comments in the
code below.

Sub Test2()
'
Dim todaysDateLong As String
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Dim sh4 As Worksheet, sh5 As Worksheet, sh6 As Worksheet
Dim rng1 As Range, rng2 As Range
Dim rng3 As Range, rng4 As Range
Dim rw As Long, cell As Range

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")
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
Set sh4 = Worksheets("PU0703LCS")
Set sh5 = Worksheets("KTL")
Set sh6 = Worksheets("LCS_KTL AI Diff")
Set rng3 = sh4.Range(sh4.Cells(2, 2), sh4.Cells(2, 2).End(xlDown))

'--I need to know if the cell above (2) if it is higher than cell (10) below

Set rng4 = sh2.Range(sh5.Cells(2, 10), sh5.Cells(2, 10).End(xlDown))

'-- If yes then copy and paste into sh6

If Application.CountIf(rng4, cell.Value) = 0 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

 

[Guest]

Sub Test2()
'
Dim todaysDateLong As String
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Dim sh4 As Worksheet, sh5 As Worksheet, sh6 As Worksheet
Dim rng1 As Range, rng2 As Range
Dim rng3 As Range, rng4 As Range
Dim rw As Long, cell As Range
Dim i as Long

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

' really need to references to sheet KTL?
Set sh1 = Worksheets("PU0703LCS")
Set sh2 = Worksheets("KTL")
Set sh4 = Worksheets("PU0703LCS")
Set sh5 = Worksheets("KTL")
Set sh6 = Worksheets("LCS_KTL AI Diff")
rw = 2
i = 0
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
Set rng3 = sh4.Range(sh4.Cells(2, 2), sh4.Cells(2, 2).End(xlDown))

'--I need to know if the cell above (2) if it is higher than cell (10) below

Set rng4 = sh2.Range(sh5.Cells(2, 10), sh5.Cells(2, 10).End(xlDown))

i = i + 1
If rng4(i) < cell.Value 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

 

[Guest]

Les:

You can tidy the code up a little as in and you don't need the extra sheets:

Sub Test2()
'
Dim todaysDateLong As String
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Dim sh4 As Worksheet, sh5 As Worksheet, sh6 As Worksheet
Dim rng1 As Range, rng2 As Range
Dim rng3 As Range, rng4 As Range
Dim rw As Long, cell As Range

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

Set sh2 = Worksheets("KTL")
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
' Set sh4 = Worksheets("PU0703LCS") ' this is the same as sh1
' Set sh5 = Worksheets("KTL") ' this is the same as sh2
Set sh6 = Worksheets("LCS_KTL AI Diff")
Set rng3 = sh1.Range(sh1.Cells(2, 2), sh1.Cells(2, 2).End(xlDown))

'--I need to know if the cell above (2) if it is higher than cell (10) below

Set rng4 = sh2.Range(sh2.Cells(2, 10), sh2.Cells(2, 10).End(xlDown))

'>>>>>> is this sh2 or sh5 ? seems to be different sheets
if sh1.Cells(2, 2) > sh2.Cells(2, 10) then
'>>>> do something
end if
'-- If yes then copy and paste into sh6

If Application.CountIf(rng4, cell.Value) = 0 Then
cell.EntireRow.Copy sh6.Cells(rw, 1)
rw = rw + 1
End If

End If
Next

Range("A1").Select ' what sheet is this on..
Columns("A:O").EntireColumn.AutoFit
End Sub

 

[Guest]

Hello Tom, thank you for your reply. This is unfortunately not doing what i
would like it to do. I have sent a copy of the spreadsheet to your e-mail
address.

best regards,

 

[Les Stout]

Hi Tom, did not think you would be awake... :0), Did you get my E-Mail
??

Best regards,

Les Stout

 

[Guest]

Yes I got your email, but since you provided no additional information to
explain what you wanted, it is no clearer than it was when I answered here
and you said that didn't do what you want.

 

[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.

 

[Les Stout]

Thanks will try it Tom, i put comments in the spreadsheet and thought
would be suffient.

Best regards,

Les Stout

 

[Les Stout]

Hello all, thank you so much for your inputs and a very special thanks
to Tom Ogilvy, it is doing exactly what i need, thank you... Very, very
much appreciated...

Best regards,

Les Stout