填充偏移量（0，-1），直到在 VBA 中匹配特定值答案

【问题标题】：Fill offset(0,-1) until particular value is matched in VBA填充偏移量（0，-1），直到在 VBA 中匹配特定值
【发布时间】：2013-08-27 15:03:50
【问题描述】：

我是 VBA 新手，我正在尝试解决一个问题。我在 Excel 数据中有 Only Items 列，如下所示。我想为代码列中的每个项目添加代码。

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

但是，这并不能满足我的需要。请有人告诉我在这种情况下该怎么办？

【问题讨论】：

你让它工作了吗？

标签： excel for-loop vba

【解决方案1】：

此代码使用不同的方法（do while），但可以实现您想要的。它通过在单元格中查找冒号: 来识别类别。然后它设置 code 并将其应用于 offset(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

样本输出：

【讨论】：

+1。这是一个不错的解决方案，加上汽车和操作系统的额外好处。

【解决方案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

【讨论】：

+1 体育精神和right(, 1) = : 更快的方法

【解决方案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

【讨论】：