look in second worksheet if value not found

[boegerscience]

Hi everyone,
Using email addresses in Workbook1, I need to find those email
addresses in Workbook2, then copy/paste, the 8 cells next to the found
cells back to Workbook1. The macro goes down each cell until it hits
a blank one a stops. It's my first macro ever so pardon if it's
ugly. If you see something where you go, "WTF was he doing?" let me
know what a better way is. I appreciate the feedback.

My macro uses the FIND method and I want it to look at worksheet 2 if
it doesn't find it. Something like

If foundcell is nothing then
(look in worksheet two instead)
else
(do the normal stuff)

I tried creating a second range similar to oRng except with
Worksheets(2) and using that in the "If" statement but it didn't
work. Also, I'll need some sort of On Error Resume Next if the value
isn't found in either worksheets.

Here's my current code:

Option Explicit
Option Compare Text
Sub PasteValues()
Dim aRng as Range
Dim oRng as Range
Dim rfoundCell as Range
Dim count as Byte
Const CELLNUM as Byte = 8 'the number of cells to copy, I want
this flexible
set oRng = Workbooks("sourcesheet.xls").Worksheets(1).Range("A:H")
set aRng = ActiveCell

Do While aRng.Value <> ""
On Error Resume Next
Set rFoundCell = oRng.Find(aRng.Value, LookIn:=xlValues)
count = 1
Do Until count = CELLNUM
aRng.Offset(0, count).Value = rfoundCell.Offset(0,
count).Value
count = count + 1
Loop
Set aRng = aRng.Offset(1,0)
Loop
set aRng = Nothing
set rfoundCell = Nothing
set oRng = Nothing

End Sub

Thanks a bunch. As an aside, if anyone has a really good book
suggestion, I'm a taker. I read online help and most of Excel 2003
programming Inside and Out and I guess this is as far as it got me.

 

[Guest]

Hi ?????,

I have had a look at your request. The following code should achieve the
first part of your requirements but I have not done anything with the 'Not
Found'.

Since you seem eager to learn you might like to try it yourself. Just set up
a find, copy, paste in the Else part of the If, Then, Else test for the find
using the same value to find.

If you post a reply to this and let me know how you go then I am happy to
help further if you need it.

I have left a msgbox in the For Each Loop. It helps with testing. Simply
place a single quote at the beginning of it to comment it out when you no
longer need it.

If you want to stop the program at any time during the loop, including when
the msgbox is displayed then Ctrl/Break will stop it.

In Find you should always use all the Arguments (parameters) because xl
remembers them from the last use even if it was in the interactive mode.
Things like After Activecell have to come out but most of the others remain.
If unsure, record a macro to see which ones it uses. The .Activate at the end
also comes off. See this in help and click on show all and read about it in
Remarks.

Sub PasteValues()

Dim wb1 As Workbook 'Workbook1
Dim wb2 As Workbook 'Workbook2
Dim rng1 As Range 'Range of cells to be found Workbook1
Dim rng2 As Range 'Range to look in Workbook2
Dim cel_1 As Range 'Each cell in rng1
Dim rfoundCell As Range 'Range of found cell
Dim cellNum As Single 'The number of cells to copy

cellNum = 8 'Set this to any number you like

'Replace workbook names in the following 2 lines
'with your workbook names
Set wb1 = Windows.Application.Workbooks("Workbook1.xls")
Set wb2 = Windows.Application.Workbooks("Workbook2.xls")

Set rng1 = wb1.Worksheets(1).Range("A1:A100") 'Cells to find
Set rng2 = wb2.Worksheets(1).Range("A1:A1000") 'Range to look in

For Each cel_1 In rng1 'Loops through each cell in range

'Next 3 lines skips blank cell
If Len(Trim(cel_1.Value)) = 0 Then
GoTo endForEach
End If

Set rfoundCell = rng2.Find(cel_1.Value, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)

'Next line will allow processing if value is found
If Not rfoundCell Is Nothing Then

'Delete the next line after testing
MsgBox "found " & rfoundCell.Value

'Copy 8 cells to right of found cell in workbook2
wb2.Worksheets(1).Range(rfoundCell.Offset(0, 1), _
rfoundCell.Offset(0, cellNum)).Copy

'Paste copied cells to right of cell to find wb1
wb1.Worksheets(1).Paste Destination:= _
Worksheets(1).Range(cel_1.Offset(0, 1), _
cel_1.Offset(0, cellNum))

Else
'Insert your code here to handle values not found
MsgBox "Did not find " & cel_1.Value & " Address " & cel_1.Address
End If

endForEach:
Next cel_1

End Sub

Regards and best of luck with it,

OssieMac

 

[Guest]

Hi again,

I confess that the real reason that I did not complete the project for you
was not so much to give you the chance to do it but because I ran out of time.

I have had another look at it and I think that I misinterpreted your use of
blank cell and macro stops. I thought that your macro was unintentionally
aborting on the blank cell but now I think you were using it to determine the
end of the data.

Anyway here is another version which actually finds the end of your data on
each sheet. You will find the method invaluable in the future. I have also
handled looking in sheet 2 if value not found in sheet 1.

With the method used, there is no need for On Error Resume Next for values
not found. In fact, while I admit there are times when the On Error can be a
good tool, I hate using it because one time it did mask an error that needed
to be trapped.

If you have a problem with it then let me know.

Sub PasteValues()

Dim wb1 As Workbook 'Workbook1 - Names to be found
Dim wb2 As Workbook 'Workbook2 - Data to look in
Dim rng1 As Range 'Range of cells to be found Workbook1
Dim rng2 As Range 'Range to look in Workbook2.Sheet1
Dim rng3 As Range 'Range to look in Workbook2.Sheet2
Dim cel_1 As Range 'Each cell in rng1
Dim rfoundCell As Range 'Range of found cell
Dim cellNum As Single 'The number of cells to copy

cellNum = 8 'Set this to any number you like

'Replace workbook names in the following 2 lines
'with your workbook names
Set wb1 = Windows.Application.Workbooks("Workbook1.xls")
Set wb2 = Windows.Application.Workbooks("Workbook2.xls")

'Name the range of cells to find in wb1.Sht1
'Note:Cells(Rows.count).End(xlUp) is like
'selecting the last cell in column A and
'Pressing Ctrl/Up arrow. It stops on the
'first non empty cell thus identifying it.
wb1.Activate
Worksheets(1).Activate
Set rng1 = wb1.Worksheets(1). _
Range("A1", Cells(Rows.count, 1).End(xlUp))
rng1.Select

'Name the Range of cells in wb2.Sht 1 to look in
wb2.Activate
Worksheets(1).Activate
Set rng2 = wb2.Worksheets(1). _
Range("A1", Cells(Rows.count, 1).End(xlUp))

'Name the Range of cells in wb2.Sht 2 to look in
Worksheets(2).Activate
Set rng3 = wb2.Worksheets(2). _
Range("A1", Cells(Rows.count, 1).End(xlUp))

wb1.Activate
Worksheets(1).Activate
For Each cel_1 In rng1 'Loops through each cell in range

'Next 3 lines skips any blank cells
If Len(Trim(cel_1.Value)) = 0 Then
GoTo endForEach
End If

Set rfoundCell = rng2.Find(cel_1.Value, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)

'If not found in Sheet 1, try sheet 2
If rfoundCell Is Nothing Then
Set rfoundCell = rng3.Find(cel_1.Value, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
End If

'Process if value found in either Sheet 1 or 2
If Not rfoundCell Is Nothing Then

'Copy 8 cells to right of found cell in workbook2
Range(rfoundCell.Offset(0, 1), _
rfoundCell.Offset(0, cellNum)).Copy

'Paste copied cells to right of cell to find wb1
'NOTE: Only need to nominate first cell of range.
wb1.Activate
Worksheets(1).Activate
ActiveSheet.Paste Destination:=Range(cel_1.Address).Offset(0, 1)
Else
End If

endForEach:
Next cel_1

End Sub