Jump to spot in a range of cells that is alphabetically correct

[madhattt]

This is for Excel 2010 VBA

I have a named range called "Find_Item", when I type something in I want it to search for that name in a range that also contains spaces. If that name isn't there then I want it to jump to the appropriate alphabetical spot.

This is the macro I have now, below. It works if there is a match of the name, but it looks through the list, and if the name doesn't match, it takes away a letter and searches again. If there is no match then it goes backwards through the alphabet until it finds something. I can type "shkas" and it will find the first cell that starts with "shkas" then if there is no match, "shka" then "shk" then "sh" then "s" then "r" then "q" and so on until it finds something.

The problem is that, say there is

McDonalds
McDonalds
McDonalds
McDonalds

Mid State
Mid State

Muns Construction
Muns Construction
Muns Construction

If I type in "Moes", it will goto the first "McDonalds" entry because it will search for "Moes", find nothing and then search for "Moe", then "Mo", then "M" and find "McDonalds" because that is the first cell with a "M".

What I need it to do is activate the cell between "Mid State" and "Muns Construction" so I can add "Moes" in manually.

I tried the sort but because of the empty rows and other data in my book, it is not possible and as far as I can tell, the find function stops because of the spaces in between that aren't removable. This code is the closest I could get but it needs some refinement. I am also using a Private Sub Worksheet_Change to fire this macro when I hit the enter key or tab after I type in the name I am looking for.

Sub Find_Letter()

  Dim s As String, r As Long, Rng As Range, asdf As Integer, oll As String
    
    On Error GoTo Errortrap1
    
    Set Rng = Range("B12", Cells(Rows.Count, "B").End(xlUp))    'The range is from B12:B1386 and changes as I add to it.
    
    s = Range("Find_Item").Value   'This is in cell B7
    If s = "" Then Exit Sub              'Sub will not run if cell is blank
    asdf = Len(s)                           'Finds the length of the cell value
    oll = Chr(Asc(s) - 1)                  'This gives a numeric value to the letter and then goes back one letter
    
Application.ScreenUpdating = False

Beginit:
    For r = 1 To Rng.Rows.Count
      If StrComp(Mid(Rng.Item(r), 1, asdf), Mid(s, 1, asdf), vbTextCompare) = 0 Then
         Application.Goto Rng.Item(r - 1), Scroll:=True
         ActiveCell.Offset(1, 0).Select
         ActiveWindow.LargeScroll , , , 1
         Application.ScreenUpdating = True
         Exit Sub
      End If
    Next r
   
    If asdf > 1 Then
        asdf = asdf - 1
        GoTo Beginit
    End If
    If asdf <= 1 Then                 ''This is where it starts going backwards in the alphabet.

Nextbegin:
        For r = 1 To Rng.Rows.Count
            If StrComp(Left(Rng.Item(r), 1), Left(oll, 1), vbTextCompare) = 0 Then
                Application.Goto Rng.Item(r - 1), Scroll:=True
                ActiveCell.Offset(1, 0).Select
                ActiveWindow.LargeScroll , , , 1
                Application.ScreenUpdating = True
                Exit Sub
            End If
        Next r
    End If
    
oll = Chr(Asc(oll) - 1)
GoTo Nextbegin
    
Application.ScreenUpdating = True    'These three line aren't required I don't think
End
Exit Sub

Errortrap1:
Application.ScreenUpdating = True
Exit Sub

End Sub

Please let me know if you can help! Thank you in advance.