Смещение заполнения (0, -1) до тех пор, пока определенное значение не будет согласовано в VBA

Question

Я новичок в VBA, и я пытаюсь решить одну проблему. У меня есть столбец Только элементы в данных Excel, как показано ниже. И я хочу добавить код для каждого элемента, который находится в столбце Код.

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 

Я использовал следующий цикл для этого

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 

Но это не acheiving то, что мне нужно. может понравиться кто-нибудь, дайте мне знать, что делать в этом случае?

Answer 1

Этот код использует другой подход (do while), но достигает того, чего вы хотите. Он идентифицирует категорию, ища двоеточие : внутри ячейки. Затем он устанавливает code и применяет его к смещению (0, -1) до тех пор, пока не будет найден новый код.

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 

Пример вывода:

Answer 2

@mehow бил меня за несколько секунд, но этот код также будет решить вашу проблему.

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

Немного другой подход:

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