Please help!
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
"Jim Thomlinson" wrote:
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).Offse t(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
--
HTH...
Jim Thomlinson
"John" wrote:
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
"Jim Thomlinson" wrote:
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
--
HTH...
Jim Thomlinson
"John" wrote:
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
|