1

我是 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

但是，这并没有达到我所需要的。有人可以让我知道在这种情况下该怎么做吗？

4

3 回答 3

1

@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
于 2013-08-27T15:22:34.127 回答
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

样本输出：

在此处输入图像描述

于 2013-08-27T15:20:52.763 回答
0

略有不同的做法：

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
于 2013-08-27T15:42:59.383 回答