VBA查找并插入单元格更改 [英] VBA Lookup and insert on cell change

问题描述

主要工作表：

学生|成绩|目标代码|目标文本

Student | Grade | Target Code | Target Text

Jim | A | Code1 |这是与Code1对应的文本

Jim | A | Code1 | This is the text that corresponds with Code1

查找表，定义为名为目标的工作表中的名称TargetCodes：

Code1 |这是与Code1对应的文本

Code1 | This is the text that corresponds with Code1

Code2 |这是与Code2对应的文本

Code2 | This is the text that corresponds with Code2

我需要一些VBA，以便当任何记录的TargetCode字段发生更改时，相应的文本将以文本形式放入目标文本列。我不能在目标文本列中使用LOOKUP，因为文本需要编辑，如果您尝试编辑该文本，您只需编辑LOOKUP公式。对于任何类型的帮助都将不胜感激。

I need some VBA so that when the TargetCode field for any record is changed, the corresponding text is placed, in text form, into the Target Text column. I can't use a LOOKUP in the Target Text column because the text needs to be editable and if you try to edit that, you'd just be editing the LOOKUP formula. Help of any sort would be greatly appreciated.

我已经将一些代码汇集在一起​​，从StackExchange的其他位上挑选：

I've cargo-culted some code together from picking over other bits of 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'失败...

But I get the error "Method 'Range' of object '_Worksheet' failed...

任何帮助非常感谢。

解决方案

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

这篇关于VBA查找并插入单元格更改的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！