Fill offset(0,-1) until particular value is matched in VBA - excel

Question

I am new in VBA and I am trying to solve one problem. I have Only Items column in Excel data like below. And I want to add code for each item which is in Code column.
Code Items
Animals:
AN Cow
AN Dog
AN Zeebra
AN Deer
Flower:
FL Rose
FL Sunflower
Fruit:
FR Mango
FR Banana
FR Pineapple
FR Cherry
I used following Loop for that
For Each Cell In Sheets("Sheet1").Range("B" & Sheets("Sheet1").Columns("B:B").Cells.Find(what:="Animal:", searchdirection:=xlPrevious).Offset(1, 0).Row & ":B" & Sheets("Sheet1").Range("B").End(xlDown).Row)
If Cell.Value <> "Flower:" Then
Cell.Offset(1, 0).Select
Cell.Offset(0, -1).Value = "AN"
ElseIf Cell.Value = "Flower:" Then
Range(Selection, Selection.End(xlDown)).Select
Cell.Offset(0, -1).Value = "FL"
End If
Next Cell
But, this is not acheiving what I need. can please someone let me know what to do in this case?

Answer 1

This code uses a different approach (do while) but achieves what you want. It identifies the category by looking for a colon : within the cell. It then sets the code and applies it to the offset(0,-1) until a new code is found.
Sub FillOffset()
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
Dim i As Long
i = 2
Dim cell As Range
Do Until i > ws.Range("B" & Rows.Count).End(xlUp).Row
If InStr(1, ws.Range("B" & i).Text, ":", vbTextCompare) Then
Dim code As String
code = UCase(Left(ws.Range("B" & i).Text, 2))
Else
ws.Range("B" & i).Offset(0, -1) = code
End If
i = i + 1
Loop
End Sub
Sample output:

Answer 2

#mehow beat me by a a few seconds, but this code will also solve your problem.
Sub AddCodeForItems()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim lastRow As Long
Dim code As String
Set ws = ThisWorkbook.ActiveSheet
lastRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("B2:B" & lastRow)
For Each cell In rng
If Right(Trim(cell.Value), 1) = ":" Then
code = UCase(Left(Trim(cell.Value), 2))
Else
cell.Offset(, -1).Value = code
End If
Next cell
End Sub

Answer 3

Slightly different approach:
Sub tgr()
Dim rngFound As Range
Dim rngLast As Range
Dim strFirst As String
With ActiveSheet.Columns("B")
Set rngFound = .Find(":", .Cells(.Cells.Count), xlValues, xlPart)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
Set rngLast = Range(rngFound.Offset(1), .Cells(.Cells.Count)).Find(":", , xlValues, xlPart)
If rngLast Is Nothing Then Set rngLast = .Cells(.Cells.Count).End(xlUp).Offset(1)
Range(rngFound.Offset(1, -1), rngLast.Offset(-1, -1)).Value = UCase(Left(rngFound.Text, 2))
Set rngFound = Columns("B").Find(":", rngFound, xlValues, xlPart)
Loop While rngFound.Address <> strFirst
End If
End With
Set rngFound = Nothing
Set rngLast = Nothing
End Sub