VBA Loop Evaluates Cell, Copy & Paste it above Current Row, If Criteria is met

[JohnnyBconfused]

I'm a novice when it comes to VBA, and I have a list of names in Excel 2013 (Running Windows 8.1) and I want to write code that will generate and include all nicknames the person might have, so that if a user enters some variation - it will still be recognized. For example Richard would have the nicknames "Rich", "Rick", "D---". I want the code to add the additional names above the line of code that it is evaluating. I expected the code I currently have to copy and paste the row being evaluated into the newly created row(s) above. I planned to learn how to change the names later - and am currently doing it by hand. Unfortunately I'm getting a run-time error 1004 "application-defined or object-defined error", at "Rows("i:i").Select". I would like all the names to stay in the same spreadsheet. Can this be accomplished?

I've checked many examples here & on stack overflow, but none fit my use case & most send the rows to another sheet / workbook... Below is my code:

Sub insertnicknamerows()



Dim First, i, j,k,h


    For i = 1 To Rows.Count
        First = Split(Cells(i, 1).Value, " ")(0)
'this list grabs assigns the first name to the variable    



        If First = "Joe" Then
            j = i + 1
        
        
            Rows("i:i").Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Rows("j:j").Select
            Selection.Copy
            Rows("i:i").Select
            ActiveSheet.Paste
            i = j
            
        ElseIf First = "Richard" Then
            j = i + 1
            k = i + 2
            h = i + 3
            
            
            Rows("i:i").Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Rows("h:h").Select
            Selection.Copy
            Rows("i:i").Select
            ActiveSheet.Paste
            Rows("j:j").Select
            ActiveSheet.Paste
            Rows("k:k").Select
            ActiveSheet.Paste
        
            i = h
        
        End If
        
    Next i
End Sub

 

[JohnnyBconfused]

Wow - thank you! This does exactly what I was having so much trouble doing. I really appreciate your help!!



Here's the code for others who may view this thread:

Option Explicit


Sub InsertNickNameRows()
Dim shList As Worksheet
Dim shNNames As Worksheet
Dim rList As Range
Dim rNNames As Range
Dim rFind As Range
Dim sFirst As String
Dim i As Integer
Dim j As Integer


    Set shList = Worksheets("List")
    Set shNNames = Worksheets("Nicknames")
    Set rList = shList.Range("A1").CurrentRegion.Columns(1)
    Set rNNames = shNNames.Range("A1").CurrentRegion.Columns(1)
    
    Application.ScreenUpdating = False
    'Clear list of nicknames before rebuild
    For i = rList.Rows.Count To 1 Step -1
        If rList.Cells(i, 1).Font.Color = vbBlue Then rList.Cells(i, 1).EntireRow.Delete
    Next i
    'Rebuild nicknames to include edits or new names
    For i = rList.Rows.Count To 1 Step -1
        sFirst = Split(rList.Cells(i, 1).Value, " ")(0)
        With rNNames
            Set rFind = .Find(What:=sFirst, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                           SearchDirection:=xlNext, MatchCase:=False)
            If Not rFind Is Nothing Then
                For j = 1 To rFind.EntireRow.SpecialCells(xlCellTypeConstants).Count - 1
                    rList.Cells(i, 1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
                    rList.Cells(i, 1).Value = rFind.Offset(0, j).Value
                    rList.Cells(i, 1).Font.Color = vbBlue '<< Optional
                Next j
            End If
        End With
    Next i
    Application.ScreenUpdating = True
    MsgBox "List processed and appropriate nicknames inserted.", vbInformation
End Sub

Thanks Again RudiS - you saved my butt on this one