[Resolved]Problem with VBA in Excel

[jmcgill]

I am putting together a spreadsheet for my company. Their are 2 sheets in the workbook. If "New" is chosen from the combo box in column I then I am copying 4 of the fields already entered in sheet one to the corresponding fields on sheet 2. The problem i am having is that it is copying the data 4 times. I can not figure out why this is happening. If anyone can tell what is going on I would greatly appreciate it. Below is the code. File is attached.

Thanks,

Jason

Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim topCel As Range, bottomCel As Range, _
    sourceRange As Range, targetRange As Range
Dim x As Integer, i As Integer, numofRows As Integer
Set topCel = Range("I2")
Set bottomCel = Range("I65536").End(xlUp)
If topCel.Row > bottomCel.Row Then End     ' test if source range is empty
Set sourceRange = Range(topCel, bottomCel)
Set targetRange = Range("J2")
numofRows = sourceRange.Rows.Count
x = 1
For i = 1 To numofRows
    
        If sourceRange(i) = "As Is" Then
            targetRange(x) = "No Action Needed"
            x = x + 1
        End If
        If sourceRange(i) = "Group Owned" Then
            targetRange(x) = "No Action Needed"
            x = x + 1
        End If
        If sourceRange(i) = "New" Then
            targetRange(x) = "Cells Copied to Sheet2"
            DidCellsChange
            x = x + 1
            
        End If
        If sourceRange(i) = "Assign To" Then
            targetRange(x) = "Cells Copied to Sheet2"
            x = x + 1
        End If
        If sourceRange(i) = "" Then
            targetRange(x) = ""
            x = x + 1
        End If
        
    
Next
Set topCel = Range("E2")
Set bottomCel = Range("E65536").End(xlUp)
If topCel.Row > bottomCel.Row Then End     ' test if source range is empty
Set sourceRange = Range(topCel, bottomCel)
Set targetRange = Range("F2")
numofRows = sourceRange.Rows.Count
x = 1
For i = 1 To numofRows
    
        If sourceRange(i) < #11/1/2005# Then
            targetRange(x) = "No"
            x = x + 1
        End If
        If sourceRange(i) > #11/1/2005# Then
            targetRange(x) = "Yes"
            x = x + 1
        End If
    
Next
 
End Sub
Sub CopyCellsValues()
    Dim sourceRange As Range
    Dim destrange As Range
    Dim Lr As Long
    Lr = LastRow(Sheets("Sheet2")) + 1
    Set sourceRange = Sheets("Sheet1").Cells( _
    ActiveCell.Row, 1).Range("A1:E1")
    With sourceRange
        Set destrange = Sheets("Sheet2").Range("A" _
        & Lr).Resize(.Rows.Count, .Columns.Count)
    End With
    destrange.Value = sourceRange.Value
End Sub
 
 
Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function
 
Sub DidCellsChange()
  Dim KeyCells As String
   ' Define which cells should trigger the KeyCellsChanged macro.
   KeyCells = "J2:J65000"
 
   ' If the Activecell is one of the key cells, call the
   ' KeyCellsChanged macro.
   If Not Application.Intersect(ActiveCell, Range(KeyCells)) _
   Is Nothing Then KeyCellsChanged
 
End Sub
 
Sub KeyCellsChanged()
   Dim Cell As Object
   ' If the values in A11:C11 are greater than 50...
   For Each Cell In Range("I2:I65000")
   If Cell = "New" Then
    CopyCellsValues
 
   End If
   Next Cell
 
End Sub