1

私は VBA が初めてで、1 つの問題を解決しようとしています。以下のように、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

しかし、これは私が必要とするものを達成していません。この場合どうすればよいか誰か教えてください。

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 に答える