Find cell in Range and If found then copy to next sheet

**Sachy** · 02-15-2013, 09:00 AM

Hello, I need a macro that will do the following:

I have two sheets with data with many columns and rows, on the sheet1 in column B are listed serial numbers which I want to find in sheet2 (they are also listed in column B). When the serno will match, then copy entire row from sheet1 (for the specific serno.) to the place where the serno is placed in sheet2, but start pasting from column A.

Hope I explained it clear, any suggestions ?

**Sachy** · 02-18-2013, 10:52 AM

Well I was able to put the code together alone, because nobody has replied to my thread

This is what I have so far, but I would like to insert a msgbox into code, so user can define the source and target range. Please can you help me with it ?

Sub Find_Serialnumber()

    Dim c As Range, d As Range
    Dim dCol As Integer
    
    ' Speed
    calc = Application.Calculation
    With Application
     .Calculation = xlCalculationManual
     .ScreenUpdating = False
     End With
    
    Worksheets("Source").Activate
    For Each c In Worksheets("Source").Range("B1:B748")
        For Each d In Worksheets("Target").Range("B1:B3487")
            
            If c = d Then
            On Error Resume Next
            dCol = d.Column
            
            c.EntireRow.Copy d.Offset(0, -1)
            On Error Resume Next
            
            
                Exit For
            End If
        Next
    Next
   Application.CutCopyMode = False
   Worksheets("Target").Activate
  Range("B1").Select

End Sub

**bob33** · 02-18-2013, 11:25 AM

try:

Sub TestInputBox()
    Dim myRange As Range
 
    Set myRange = Application.InputBox(Prompt:= _
        "Please Select a Range", _
        Title:="InputBox Method", Type:=8)
 
    If myRange Is Nothing Then
        ' Range is blank
    Else
        myRange.Select
    End If
End Sub

**Sachy** · 02-20-2013, 04:54 AM

Thanks bob33 for your answer, I know how the msgbox code looks like but how to implement it to my code ? The code should look something like this:

Sub Find()

    Dim c As Object, d As Object
    Dim dCol As Integer
    Dim Source As Range
    Dim Target As Range
    
    ' Speed
   ' calc = Application.Calculation
   ' With Application
   ' .Calculation = xlCalculationManual
   ' .ScreenUpdating = False
   '  End With
    
    Set Source = Application.InputBox( _
        Prompt:="Please enter a source range to search for", _
        Title:="InputSerialNumber", _
        Default:=ActiveCell.Address, _
        Type:=8)
    If Source Is Nothing Then
        MsgBox "No source range selected"
    'Else
    '   Source.Select
    End If
    
     On Error Resume Next
    Set Target = Application.InputBox( _
        Prompt:="Please enter a target range to search in", _
        Title:="OutputSerialNumber", _
        Default:=ActiveCell.Address, _
        Type:=8)
    If Target Is Nothing Then
        MsgBox "No source range selected"
    'Else
    '    Target.Select
    End If
     
    Worksheets("Source").Activate
    c = Worksheets("Source").Source  - HERE IS THE PROBLEM PART, HOW TO DEFINE THAT FOR EACH CELL FROM SELECTED RANGE FROM PREVIOUS STEP, SERCH FOR MATCH AND THEN COPY WHOLE ROW FROM SOURCE SHEET TO THE RIGHT PLACE IN TARGET SHEET
    d = Worksheets("Target").Target
     For Each c In Worksheets("Source").Source
        For Each d In Worksheets("Target").Target
        
            If c = d Then
            On Error Resume Next
            dCol = Target.Column
            
            Source.EntireRow.Copy Target.Offset(0, -1) 
            On Error Resume Next
            
            
                'Exit For
            End If
        Next
    Next
   Application.CutCopyMode = False
   Worksheets("Target").Activate
  Range("A1").Select

End Sub

Any ideas how to resolve it ? Thanks in advance!

**arlu1201** · 02-20-2013, 04:58 AM

Sachy,

Welcome to the forum.

I have added code tags to your posts. As per forum rule 3, you need to use them whenever you put any code in your post. Please add them in future. If you need more information on how to use them, check my signature below this post.

**Sachy** · 03-20-2013, 10:56 AM

After reading some similar threads and also googling around (which takes pretty much time), I was able to put together a functional version of code, that does exactly what I want. So here it is, if anybody is dealing with same problem:

Public Sub SerialSearch()
Dim cell1 As Range
Dim Source As Range
Dim cell2 As Range
Dim Target As Range

Set Source = Application.InputBox( _
        Prompt:="Please enter a source range to search for", _
        Title:="InputSerialNumber", _
        Default:=ActiveCell.Address, _
        Type:=8)
    If Source Is Nothing Then
        MsgBox "No source range selected"

     End If
    
     On Error Resume Next

    Set Target = Application.InputBox( _
        Prompt:="Please enter a target range to search in", _
        Title:="OutputSerialNumber", _
        Default:=ActiveCell.Address, _
        Type:=8)
    If Target Is Nothing Then
        MsgBox "No source range selected"

    End If

    On Error Resume Next

For Each cell1 In Source
    With Target
        Set cell2 = .Find(cell1.Value, LookIn:=xlValues)
        
If cell2.Value <> cell1.Value Then
           
            cell1.Interior.ColorIndex = 3 'When searching serial numb. is not found, change its cell color into red  
Else
                Worksheets("Source").Activate
                Set aaa = ActiveSheet.Range(cell1.Offset(0, -1), cell1.Offset(0, 32))
                aaa.Copy
                
                Worksheets("Target").Activate
                cell2.Offset(0, -1).Select
                ActiveSheet.Paste
                
            End If
    End With
Next cell1

End Sub