Excel VBA大型表，添加评论Vlookup，命中button后
我有一张大桌子，我想添加注释的信息属于Range(D11:CY148) 。 我有两个选项卡 – “完成matrix”（主）和“列表”（隐藏 – 有2列）。
我有两个问题。
第一个问题 – 代码在一定程度上起作用，在单元格中键入我的值后，它会自动根据另一个表中的信息添加注释。 问题是有太多的细胞被手动input，如果我复制和粘贴代码不运行。 我创build了一个CommandButton，并希望它刷新整个表的注释取决于如果单元格的值在“列表”中。 我试图创build一个调用Worksheet_Change但无济于事。 （我是一个初学者，所以如果你解释它会有帮助的）
第二个问题 – 我假设它会得到解决任何build议的作品。 偶尔input一个单元格后，我会得到一个错误。 不记得错误的名称，但它是常见的错误之一，atm错误不会popup，但肯定会回来，因为我没有做任何不同的代码。
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
感谢您的帮助！
未经testing，但是这将取得Range(D11:CY148)所有值，并根据表格“list”中的查找添加注释。
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
你基本上错过了For Each Cell in Target部分的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
添加注释子允许追加是需要的…
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