simplifying code- loop??

[akforsyt]

I have the following code. I would like to do this same operation for several more rows. I'm sure there has got to be a way to simplify this using some type of loop or variables, but I can't figure it out. What I am doing is pasting copied text into the cell when I click on it, then looking up a cell in the same row that I copied from and pasting this value next to it.

If Target.Address = "$E$3" Then
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

FndStr = Cells(3, 5)
     Set FndVal = Columns("C").Find(What:=FndStr, LookAt:=xlWhole)
        If FndVal Is Nothing Then
           MsgBox "No End Time Found"
        Else
            FndVal.Offset(0, 4).Copy
        End If
        Cells(3, 6).Select
        Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End If


If Target.Address = "$E$4" Then
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

FndStr = Cells(4, 5)
     Set FndVal = Columns("C").Find(What:=FndStr, LookAt:=xlWhole)
        If FndVal Is Nothing Then
           MsgBox "No End Time Found"
        Else
            FndVal.Offset(0, 4).Copy
        End If
        Cells(4, 6).Select
        Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End If

The parts that change I have replaced with X below (x is all the same #)...

If Target.Address = "$E$X" Then
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

FndStr = Cells(X, 5)
     Set FndVal = Columns("C").Find(What:=FndStr, LookAt:=xlWhole)
        If FndVal Is Nothing Then
           MsgBox "No End Time Found"
        Else
            'MsgBox FndVal.Offset(0, 6).Value
            FndVal.Offset(0, 4).Copy
        End If
        Cells(X, 6).Select
        Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End If

Help please!

 

[westconn1]

you could use

if target.column = 5 then 
select case target.row
  case 4 'address "e4"
         'your code
  case 5 'address "e5"
         'your code
    'etc

 

[Von Pookie]

It looks like you may have taken your sample code from a larger macro, but perhaps something like this?

Dim RowStart As Long, RowEnd As Long, i As Long
Dim FndStr As Range, FndVal As Range

Do
    On Error Resume Next
    RowStart = Application.InputBox("Enter the start row:", Type:=1)
    On Error GoTo 0
    If RowStart < 1 Or RowStart >= Rows.Count Then MsgBox "You must enter a number between 1 and " & Rows.Count & "."
Loop While RowStart < 1 Or RowStart >= Rows.Count
    
Do
    On Error Resume Next
    RowEnd = Application.InputBox("Enter the end row:", Type:=1)
    On Error GoTo 0
    If RowEnd < RowStart Then
        MsgBox "You must enter a row number greater than the start row of " & RowStart & "."
    ElseIf RowEnd < 1 Or RowEnd > Rows.Count Then
        MsgBox "You must enter a number between 1 and " & Rows.Count & "."
    End If
Loop While RowEnd < 1 Or RowEnd > Rows.Count Or RowEnd < RowStart

For i = RowStart To RowEnd
    Set FndStr = Cells(i, 5)
    Set FndVal = Columns("C").Find(What:=FndStr.Value, LookAt:=xlWhole)
    If FndVal Is Nothing Then
        MsgBox "No End Time Found"
    Else
        FndVal.Offset(0, 4).Copy
    End If
    FndStr.Offset(0, 1).PasteSpecial xlPasteFormulas
Next i

 

[akforsyt]

westconn... I think that would work, but I would still have to write in the code for every row. i am looking for a simpler way to put this.

kristy- yes, this code is part of a much, much larger project...
I will try the code you have posted when I get back to work on Monday.

I will post a follow-up later.

Thanks everyone.

 

[Legacy 68668]

try

With Target.Cells(1)
    If Not Intersect(.Cells, Range("e3:e100")) Is Nothing Then"
        .PasteSpecial Paste:=xlPasteFormulas
        FndStr = .Value
        Set FndVal = Columns("C").Find(What:=FndStr, LookAt:=xlWhole)
        If FndVal Is Nothing Then
           MsgBox "No End Time Found"
        Else
            FndVal.Offset(0, 4).Copy
        End If
        .Offset(, 1).PasteSpecial Paste:=xlPasteFormulas
    End Select
End With
Application.CutCopyMode = False

 

[westconn1]

only for any rows that require different code

if target.column = 5 then 
select case target.row
  case 1 to 4 
         'your code
  case 5, 9, 11, 15
         'your code
  
    'etc

 

[Norie]

Perhaps I'm missing something but don't you already know the row you are copying from.

If you do why do you need to do any sort of lookup/find/loop?

 

[akforsyt]

thanks everyone. I've actually managed to work it out using a combination of some of the above. I used the select case and target.column stuff. I've posted the solution below. Again, thanks for all of your contributions.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim FndStr As String
Dim FndVal As Range
On Error GoTo ErrorEnd:

Application.ScreenUpdating = False
If Target.Column = 2 Then
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Select Case Target.Row
  Case 3 To 12
FndStr = Worksheets("ExtraRooms").Cells(Target.Row, Target.Column)
     Set FndVal = Worksheets("TestingSchedule").Columns("C").Find(What:=FndStr, LookAt:=xlWhole)
        If FndVal Is Nothing Then
           MsgBox "No End Time Found"
        Else
            FndVal.Offset(0, 4).Copy
        End If
       Worksheets("ExtraRooms").Cells(Target.Row, Target.Column + 1).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End Select
End If

ErrorEnd:
Application.ScreenUpdating = True

End Sub

 

[westconn1]

for the above you could use
if not intersect(target.range,range("b3:b12")) is nothing