Question

我有一张大表格，我想要在Range(D11:CY148)内添加评论的信息。我有两个标签 - ＆＃34; Finish Matrix＆＃34; （主要）和＆＃34;列表＆＃34; （隐藏 - 有2列）。

我有两个问题。

第一个问题 - 代码在一定程度上起作用，在单元格中键入我的值后，它会根据另一个工作表中的信息自动添加注释。问题是有太多的单元格要手动输入，如果我复制并粘贴代码不运行。我创建了一个CommandButton并希望它用注释刷新整个表，具体取决于单元格是否具有落在＆＃34; list＆＃34;中的值。我试图创建一个对Worksheet_Change的调用但无济于事。（我是初学者，所以如果你解释的话，它会帮助你）

第二个问题 - 我假设它可以解决任何有效的建议。有时在输入单元格后我会收到错误。无法记住错误名称，但它是常见的错误名称之一，因为错误不会弹出，但肯定会因为我没有做任何与代码不同的事情而回来

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns("A:CX")) Is Nothing Then _
If Intersect(Target, Columns("CY")) Is Nothing Then Exit Sub

Dim lRow As Integer

lRow = Sheets("list").Range("A1").End(xlDown).Row

If Target.Value = vbNullString Then Target.ClearComments

For Each cell In Sheets("list").Range("A1:A" & lRow)
    If cell.Value = Target.Value Then
        Target.AddComment
        Target.Comment.Text Text:=cell.Offset(0, 1).Value
    End If
Next cell

End Sub

感谢您的帮助！

Answer 1

你基本上错过了For Each Cell in Target部分......

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsMain As Worksheet, wsList As Worksheet
Dim cell As Range
Dim vCommentList As Variant
Dim i As Long, lLastRow As Long
Dim sValue As String

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Set wsMain = Target.Parent
    Set Target = Intersect(Target, wsMain.Range("D11:CY148"))
    If Target Is Nothing Then Exit Sub
    Set wsList = wsMain.Parent.Sheets("list")
    lLastRow = LastRow(1, wsList)
    ' Read Comment List into Variant (for speed)
    vCommentList = wsList.Range("A1:B" & lLastRow)

    Target.ClearComments
    ' This...For each Cell in Target...is what you were missing.
    For Each cell In Target
        sValue = cell
        For i = 1 To UBound(vCommentList)
            If sValue = vCommentList(i, 1) Then
                AddComment cell, CStr(vCommentList(i, 2))
                Exit For
            End If
        Next
    Next

ErrHandler:
    If Err.Number <> 0 Then Debug.Print Err.Description
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

找到最后一行的正确方法......

Public Function LastRow(Optional Col As Integer = 1, Optional Sheet As Excel.Worksheet) As Long
    If Sheet Is Nothing Then Set Sheet = Application.ActiveSheet
    LastRow = Sheet.Cells(Sheet.Rows.Count, Col).End(xlUp).Row
End Function

添加注释Sub允许附加...

Public Sub AddComment(Target As Range, Text As String)
    If Target.Count = 1 Then
        If Target.Comment Is Nothing Then
            Target.AddComment Text
        Else
            Target.Comment.Text Target.Comment.Text & vbLf & Text
        End If
    End If
End Sub

Answer 2

未经测试，但这会获取Range(D11:CY148)中的所有值，并根据“工作表”列表中的查找添加注释。

Sub testy()
    Dim arr As Variant, element As Variant
    Dim i As Long, j As Long, listItems As Long, rwLast As Long, clLast As Long
    Dim comm As String
    Dim rng As Range, cell As Range

    listItems = Sheets("list").Range("A1").End(xlDown).Row
    rwLast = Cells.SpecialCells(xlCellTypeLastCell).Row ' Adjust to fit your needs
    clLast = Cells.SpecialCells(xlCellTypeLastCell).Column 'Idem

    Set rng = Sheets("list").Range("A1:A" & listItems)
    arr = Range("D11:CY148").Value

    With Worksheets("Finish Matrix")
    For i = 1 To rwLast - 10 'Adjust to make it more general, this is pretty rough
        For j = 1 To clLast - 3 'Idem
        If i = 3 Then
        End If
            comm = ""
            For Each cell In rng
                If arr(i, j) = cell.Value Then
                    comm = comm & Chr(13) & cell.Offset(0, 1).Value
                End If
            Next cell
            If Not (comm = "") Then
                .Cells(10, 3).Offset(i, j).ClearComments
                .Cells(10, 3).Offset(i, j).AddComment
                .Cells(10, 3).Offset(i, j).Comment.Text Text:=comm

            End If
        Next j
    Next i
    End With
End Sub

Excel VBA大表，按命令按钮后添加注释Vlookup

2 个答案: