Excel VBA大きなテーブル、コメントを追加するVlookup、コマンドボタンを押した後

Question

大きなテーブルがあり、コメントを追加したい情報がRange(D11:CY148)になります。 "Finish Matrix"（メイン）と "list"（隠し - 2列あり）の2つのタブがあります。

私には2つの問題があります。

最初の問題 - コードはある程度機能します。セルに値を入力すると、別のシートの情報に基づいてコメントが自動的に追加されます。問題は手動で入力するセルが多すぎることです。コピーして貼り付けるとコードが実行されません。私はCommandButtonを作成し、セルが "list"内にある値を持っているかどうかに応じて、コメントを付けてテーブル全体をリフレッシュするようにしました。私はWorksheet_Changeにコールアウトを作成しようとしましたが、役に立たなかった。 （私は初心者ですので、説明すれば助けになります）

2番目の問題 - 私は、それがうまくいく提案で修正されると仮定しています。時にはセルに入力した後にエラーが発生することがあります。エラー名は覚えていませんが、それは一般的なものの1つです。エラーはポップアップしませんが、コードとは何もしなかったので確かに戻ってきます。

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

これはすべての値を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 

Answer 2

あなたは基本的に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