0

メイン ワークシート:

学生 | グレード | ターゲット コード | ターゲット テキスト

ジム | あ | コード 1 | これはCode1に対応するテキストです

'Targets' という名前のワークシートで 'name' "TargetCodes" として定義されたルックアップ テーブル:

コード 1 | これはCode1に対応するテキストです

コード 2 | これはCode2に対応するテキストです

任意のレコードの TargetCode フィールドが変更されたときに、対応するテキストがテキスト形式で [ターゲット テキスト] 列に配置されるように、VBA が必要です。テキストは編集可能である必要があり、それを編集しようとすると、LOOKUP 式を編集することになるため、Target Text 列で LOOKUP を使用できません。どんな種類の助けも大歓迎です。

StackExchange の他のビットをピックアップして、いくつかのコードを一緒にカーゴカルトしました。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell_to_test As Range, cells_changed As Range
Dim result As String
Dim sheet As Worksheet

    Set cells_changed = Target(1, 1)
    Set cell_to_test = Range("D2")

    If Not Intersect(cells_changed, cell_to_test) Is Nothing Then 

        Set sheet = ActiveWorkbook.Sheets("Persuasive Speaking")
        Set TargetSheet = ActiveWorkbook.Sheets("Targets")
        result = Application.WorksheetFunction.Lookup(sheet.Range("D2"),     sheet.Range("WritingTargets"))
        MsgBox ("Test")
    End If
End Sub-

しかし、「オブジェクト '_Worksheet' のメソッド 'Range' が失敗しました...

どんな助けでも大歓迎です。

4

1 に答える 1

1 
Private Sub Worksheet_Change(ByVal Target As Range)

Const COL_IDS As Long = 3
Const COL_TARG_TEXT As Long = 4

Dim rngIds As Range, c As Range, val
Dim rngTable As Range, tmp, result

    On Error GoTo haveError

    Set rngIds = Application.Intersect(Target, Target.Parent.Columns(COL_IDS))

    If Not rngIds Is Nothing Then
        Set rngTable = ThisWorkbook.Sheets("Targets").Range("TargetCodes")
        For Each c In rngIds.Cells
            tmp = Trim(c.Value)
            If Len(tmp) > 0 Then
                val = Application.VLookup(tmp, rngTable, 2, False)
                'disable events to avoid re-triggering this sub                 
                Application.EnableEvents = False
                c.EntireRow.Cells(COL_TARG_TEXT).Value = _
                                    IIf(IsError(val), "Not found!", val)
                Application.EnableEvents = True
            End If
        Next c
    End If

    Exit Sub

haveError:
    'MsgBox Err.Description
    Application.EnableEvents = True

End Sub
于 2013-01-10T18:58:42.060 に答える