Help needed with Complicated code (For me !!)

L

Les

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
 
T

Tom Ogilvy

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
 
M

Martin Fishlock

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
 
L

Les

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,
 
T

Tom Ogilvy

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

Tom Ogilvy

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

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

*** Sent via Developersdex http://www.developersdex.com ***
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Help with code needed 3
VBA Coding Help for Beginner 0
re : Copying a range from WB01 and pasting to WB02 4
Ignore case of text in code 4
Generate Subtotal Summary from Sheet1 into Sheet2 16
Help on Matching and Copying Values In Two Different Sheets 2
Help needed! Extracting Heading 3 and Contents from a Word Doc to Excel 0
Extract Text in braquet and list of terms from 2 Docs 3

Top