填充偏移量（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

此代碼使用不同的方法（，而），但實現你想要的。它通過在單元中查找冒號:來識別類別。然後它設置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