VBA Find Macro executes but problem with Copy/Paste

[BoiledNoodle]

Excel 2007, Windows XP Pro

Dim strLoan As String
Dim longCat As Long
Dim rHere As Range
Range("A1").Select
Do
ActiveCell.Offset(1, 0).Activate
strLoan = ActiveCell.Value
Set rHere = Selection
If ActiveCell.Value = 0 Then
Else
On Error Resume Next
Cells.Find(What:=strLoan, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
ActiveCell.Offset(0, 1).Activate
longCat = ActiveCell.Value
If longCat = 1 Then
ActiveCell.Offset(0, -1).Activate
Cells.FindPrevious(After:=ActiveCell).Activate
ActiveCell.Offset(0, 1).Activate
longCat = ActiveCell.Value
Range("C" & Rows.Count, "E" & Rows.Count).Copy
ActiveCell.Offset(0, -1).Activate
Cells.FindNext(After:=ActiveCell).Activate
ActiveCell.Offset(0, 2 + 3 * longCat).Activate
ActiveCell.PasteSpecial
ActiveCell.Offset(0, -2 - 3 * longCat).Activate
Cells.FindPrevious(After:=ActiveCell).Activate
ElseIf longCat <> 1 Then
ActiveCell.Offset(0, -1).Activate
Cells.FindNext(After:=ActiveCell).Activate
Range("C" & Rows.Count, "E" & Rows.Count).Copy
ActiveCell.Offset(0, 2 + 3 * longCat).Activate
ActiveCell.PasteSpecial
ActiveCell.Offset(0, -2 - 3 * longCat).Activate
Cells.FindPrevious(After:=ActiveCell).Activate
End If
End If
Loop Until ActiveCell.Value = 0

I can see the cursor move to all the desired cells when this macro executes; it just isn't dropping any data where it should be. I have been working at this stage for the last five hours with no success. Could one of you please help me troubleshoot this? I don't know whether my copy-paste methodology is broken or if it is my selection criteria

 

[svkroy]

Can you run the code by pressing F8 (step-by-step) all the way and let me know if the copy, paste function is the problem or not Else post the sheet.