Please help!

J

John

The following code pops up my msg box... meaning it doesn't find what I am
looking for. Any ideas why? Thanks for the help.

John


Dim rngToSearch As Range
Dim wks As Worksheet
Dim rngFound As Range
Dim DestCell As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wks = Sheets("data")
Set rngToSearch = Range("j7:j712")

Set rngFound = rngToSearch.Find(what:=Array(Range("d1").Value,
Range("d2").Value, Range("d3").Value, Range("d4").Value), LookIn:=xlValues,
lookat:=xlWhole)
If rngFound Is Nothing Then
Range("a6").Select
MsgBox "No new Floaters"
Else
Do
With Worksheets("vlookup")
Set DestCell = Range("a800").End(xlDown).Offset(1, 0)
End With
rngFound.EntireRow.Copy _
Destination:=DestCell
Set rngFound = rngToSearch.FindNext
Loop Until rngFound Is Nothing
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Sheets("data").Select
Range("a6").Select
End Sub
 
J

Jim Thomlinson

There are at least four issues with your code...

1. You need to specify the sheet that the range you are searching is on.
2. You can not find an array. If you try it will only look for (first or
last I don't remember which) one of the items.
3. Find is an infinite loop. You want to stop when you get back to the firts
hit.
4. When you find nest you need to specify to start looking after the itme
you just found.

More like this...

Sub test()
Call findstuff("This")
Call findstuff("That")
End Sub

Sub findstuff(ByVal StringToFind As String)
Dim wks As Worksheet
Dim rngToSearch As Range
Dim rngCurrent As Range
Dim rngFirst As Range

Set wks = ActiveSheet
Set rngToSearch = wks.Range("A1", "D100")

Set rngCurrent = rngToSearch.Find(StringToFind)
If rngCurrent Is Nothing Then
MsgBox "Not found"
Else
Set rngFirst = rngCurrent
Do
MsgBox rngCurrent.Value & vbTab & rngCurrent.Address
Set rngCurrent = rngToSearch.FindNext(rngCurrent)
Loop Until rngCurrent.Address = rngFirst.Address
End If

End Sub
 
J

John

Jim thanks for the help. I am still having some issues.
It still seems to be in and endless loop (and I have taken out the array
just for testing). It also seems to copy cells that are to the right of my
rngToSearch column... as if it is moving over from that column rather than
starting on "d" or "a" or whatever column I select.

Here is the code now.
Dim rngToSearch As Range
Dim wks As Worksheet
Dim rngFound As Range
Dim rngFirst As Range
'Dim WhatToFind As Variant
Dim DestCell As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wks = Sheets("data")
Set rngToSearch = Sheets("data").Range("j7:j712")

'WhatToFind = Array(Range("d1").Value, Range("d2").Value,
Range("d3").Value, Range("d4").Value)

Set rngFound = rngToSearch.Find(what:=Sheets("data").Range("d1").Value,
LookIn:=xlValues, Lookat:=xlWhole)
If rngFound Is Nothing Then
Range("a6").Select
MsgBox "No new Floaters"
Else
Do
'With Worksheets("vlookup")
'Set DestCell =
Sheets("vlookup").Range("a65536").End(xlUp).Offset(0, 1)
'End With
Set rngFirst = rngFound
saddr = rngFound.Address
myrow = rngFound.Row
'rngFound.EntireRow.Copy
'Destination:=DestCell
Range("a" & myrow, "j" & myrow).Copy
Sheets("vlookup").Select
Range("a65536").End(xlUp).Offset(1, 0).Select
ActiveCell.PasteSpecial xlValues
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound Is Nothing Or rngFound.Address = rngFirst.Address
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Sheets("data").Select
Range("a6").Select
End Sub
 
J

Jim Thomlinson

Give this a whirl...

Dim rngToSearch As Range
Dim wks As Worksheet
Dim rngFound As Range
Dim rngFirst As Range
'Dim WhatToFind As Variant
Dim DestCell As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wks = Sheets("data")
Set rngToSearch = wks.Range("j7:j712") '***Changed

'WhatToFind = Array(Range("d1").Value, Range("d2").Value,
'Range("d3").Value, Range("d4").Value)

Set rngFound = rngToSearch.Find(what:=Sheets("data").Range("d1").Value, _
LookIn:=xlValues, Lookat:=xlWhole)
If rngFound Is Nothing Then
Range("a6").Select
MsgBox "No new Floaters"
Else
Set rngFirst = rngFound '***Moved...
Do
'With Worksheets("vlookup")
'Set DestCell =
'Sheets("vlookup").Range("a65536").End(xlUp).Offset(0, 1)
'End With

saddr = rngFound.Address
myrow = rngFound.Row
'rngFound.EntireRow.Copy
'Destination:=DestCell
Range("a" & myrow, "j" & myrow).Copy
Sheets("vlookup").Select
Range("a65536").End(xlUp).Offset(1, 0).Select
ActiveCell.PasteSpecial xlValues
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound Is Nothing Or rngFound.Address = rngFirst.Address
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Sheets("data").Select
Range("a6").Select
End Sub
 
J

John

jim, that fixed the endless loop, but I am only getting one row pasted for
each macro (running it four times). Also, the time I run it with D1 value, I
am not getting the data pasted in correctly. Thanks alot for your help

here is the code I am using

Sub find()
Call colorprep(Sheets("data").Range("d1").Value)
Call colorprep(Sheets("data").Range("d2").Value)
Call colorprep(Sheets("data").Range("d3").Value)
Call colorprep(Sheets("data").Range("d4").Value)
End Sub
Sub colorprep(ByVal StringToFind As String)
Dim rngToSearch As Range
Dim wks As Worksheet
Dim rngFound As Range
Dim rngFirst As Range
'Dim WhatToFind As Variant
Dim DestCell As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wks = Sheets("DATA")
Set rngToSearch = wks.Range("j7:j712")

'WhatToFind = Array(Range("d1").Value, Range("d2").Value,
Range("d3").Value, Range("d4").Value)

Set rngFound = rngToSearch.find(StringToFind)
If rngFound Is Nothing Then
Range("a6").Select
MsgBox "No new Floaters"
Else
Set rngFirst = rngFound
Do
saddr = rngFirst.Address
myRow = rngFirst.Row
'rngFound.EntireRow.Copy
'Destination:=DestCell
Range("a" & myRow, "j" & myRow).Select
Selection.Copy
Sheets("vlookup").Select
Range("a65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound Is Nothing Or rngFound.Address = rngFirst.Address
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Sheets("data").Select
Range("a6").Select
End Sub
 
J

Jim Thomlinson

This should cover it...

Sub find()
Call colorprep(Sheets("data").Range("d1").Value)
Call colorprep(Sheets("data").Range("d2").Value)
Call colorprep(Sheets("data").Range("d3").Value)
Call colorprep(Sheets("data").Range("d4").Value)
End Sub

Sub colorprep(ByVal StringToFind As String)
On Error GoTo ErrorHandler
Dim rngToSearch As Range
Dim wksData As Worksheet
Dim wksLookup As Worksheet
Dim rngFound As Range
Dim rngAllFound As Range
Dim rngFirst As Range
Dim rngDestination As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wksData = Sheets("Data")
Set wksLookup = Sheets("Lookup")
Set rngDestination = wksLookup.Cells(Rows.Count, _
"A").End(xlUp).Offset(1, 0)
Set rngToSearch = wksData.Range("j7:j712")
Set rngFound = rngToSearch.find(StringToFind)

If rngFound Is Nothing Then
MsgBox "No new Floaters"
Else
Set rngFirst = rngFound
Set rngAllFound = rngFound.Offset(0, -9).Resize(rngFound.Rows.Count, _
rngFound.Columns.Count + 9)
Do
Set rngAllFound = Union(rngAllFound, rngFound.Offset(0, -9) _
.Resize(rngFound.Rows.Count, rngFound.Columns.Count + 9))
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound.Address = rngFirst.Address
End If

'rngAllFound.EntireRow.Copy
rngAllFound.Select
rngAllFound.Copy
rngDestination.PasteSpecial Paste:=xlPasteValues

wksData.Select
wksData.Range("A6").Select

ErrorHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
 
J

John

Jim,
thanks again for the help but nothing copies for me... I am not sure what
this section is doing:rngFound.Offset(0, -9).Resize(rngFound.Rows.Count,
rngFound.Columns.Count + 9)

perhaps we are counting down and up the same number and everything is
pasting over each other...? not sure.
 
J

John

oops forgot the code...

On Error GoTo ErrorHandler
Dim rngToSearch As Range
Dim wksData As Worksheet
Dim wksVLookup As Worksheet
Dim rngFound As Range
Dim rngAllFound As Range
Dim rngFirst As Range
Dim rngDestination As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wksData = Sheets("Data")
Set wksVLookup = Sheets("VLookup")
Set rngDestination = wksVLookup.Cells(Rows.Count, _
"A").End(xlUp).Offset(1, 0)
Set rngToSearch = wksData.Range("j7:j712")
Set rngFound = rngToSearch.find(Sheets("data").Range("d1").Value,
LookIn:=xlValues)

If rngFound Is Nothing Then
MsgBox "No new Floaters"
Else
Set rngFirst = rngFound
Set rngAllFound = rngFound.Offset(0, -9).Resize(rngFound.Rows.Count, _
rngFound.Columns.Count + 9)
Do
Set rngAllFound = Union(rngAllFound, rngFound.Offset(0, -9) _
.Resize(rngFound.Rows.Count, rngFound.Columns.Count + 9))
rngAllFound.Select
rngAllFound.Copy
rngDestination.PasteSpecial Paste:=xlPasteValues
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound.Address = rngFirst.Address
End If
wksData.Select
wksData.Range("A6").Select

ErrorHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
 
J

John

I got this to work.... I have four seperate macros and call each one from a
master macro. Appreciate the help Jim

Sub find1()
On Error GoTo ErrorHandler
Dim rngToSearch As Range
Dim wksData As Worksheet
Dim wksVLookup As Worksheet
Dim rngFound As Range
Dim rngAllFound As Range
Dim rngFirst As Range
Dim rngDestination As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wksData = Sheets("Data")
Set wksVLookup = Sheets("VLookup")

Set rngDestination = wksVLookup.Cells(Rows.Count, _
"A").End(xlUp).Offset(1, 0)
Set rngToSearch = wksData.Range("j7:j712")
Set rngFound = rngToSearch.find(wksData.Range("d1").Value,
LookIn:=xlValues)
If rngFound Is Nothing Then
MsgBox "No new Floaters"
Else
Set rngFirst = rngFound
Set rngAllFound = rngFound.Offset(0, -9)
Do
Range(rngAllFound, rngFound).Copy
rngDestination.PasteSpecial Paste:=xlPasteValues
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound.Address = rngFirst.Address
End If
wksData.Select
wksData.Range("A6").Select

ErrorHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub
 

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

loop with array 6
Delete rows macro 3
Find next problem 1
Test variable range for 'Delete'; then delete the row 2
copy and paste a row 16
Find and loop help-multiple columns 4
help with macro 9
find an array, only finds first entry 4

Top