VBA to insert comments from a range if Condition is met?

[aashish83]

I have a sheet 1 which has 200 questions (B30:B230) and its serial number in (A30:A230) then sheet 2 has the Intent (description of these questions) in range (B1:B300) i need a code where it can match the serial number in (A30:A230) against (B1:B300) in sheet 2 and if its a match it should insert the intent in question cell (B30:B230) in sheet 1 as a comment....so one comment for each question on the basis of serial number

Sheet 1
Column A Column B
Row 30 : Serial no. 7.1.2 Question - your name

Sheet 2
Row 1 : Intent - 7.1.2 Please provide your full name

 

[DanteAmor]

To be clear about how you have the data on each sheet

varios 24mar2022.xlsm
	A	B
1
29	Serial no.	Question
30	7.1.2	your name
31	7.1.3	Address
32
Sheet1

On sheet2, you only have one column:

varios 24mar2022.xlsm
	B
1	Intent
2	7.1.2 Please provide your full name
3	7.1.3 Please provide your full address
4
Sheet2

The result you want on sheet1 is:

You could confirm.

 

[aashish83]

Yes

To be clear about how you have the data on each sheet

varios 24mar2022.xlsm
	A	B
1
29	Serial no.	Question
30	7.1.2	your name
31	7.1.3	Address
32
Sheet1

On sheet2, you only have one column:

varios 24mar2022.xlsm
	B
1	Intent
2	7.1.2 Please provide your full name
3	7.1.3 Please provide your full address
4
Sheet2

The result you want on sheet1 is:
View attachment 60880

You could confirm.

Yes that is the case

 

[DanteAmor]

Try this:

Sub insert_comments()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long
  Dim f As Range
  Dim serial As String
  
  Application.ScreenUpdating = False
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  
  For i = 30 To sh1.Range("A" & Rows.Count).End(3).Row
    serial = sh1.Range("A" & i).Value
    Set f = sh2.Range("B:B").Find(serial, , xlValues, xlPart, , , False)
    If Not f Is Nothing Then
      With sh1.Range("B" & i)
        If Not .Comment Is Nothing Then .ClearComments
        .AddComment
        .Comment.Visible = True
        .Comment.Text Text:=Mid(f.Value, Len(serial) + 1)
      End With
    End If
  Next
  Application.ScreenUpdating = True
End Sub

 

[aashish83]

Try this:

Sub insert_comments()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long
  Dim f As Range
  Dim serial As String
 
  Application.ScreenUpdating = False
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
 
  For i = 30 To sh1.Range("A" & Rows.Count).End(3).Row
    serial = sh1.Range("A" & i).Value
    Set f = sh2.Range("B:B").Find(serial, , xlValues, xlPart, , , False)
    If Not f Is Nothing Then
      With sh1.Range("B" & i)
        If Not .Comment Is Nothing Then .ClearComments
        .AddComment
        .Comment.Visible = True
        .Comment.Text Text:=Mid(f.Value, Len(serial) + 1)
      End With
    End If
  Next
  Application.ScreenUpdating = True
End Sub

Thank You so much worked great except that the comment box is small and for larger comments i have to manually expand the comment box ? any chance for this to be fixed

 

[JoeMo]

Here's a routine you can call from Dante's routine. Place the call just above the Application.ScreenUpdating = True line.

Sub AutoSizeComments()
'Autosizes all comments on activesheet
 Dim oCom As Comment
  Dim lArea As Long
  For Each oCom In ActiveSheet.Comments
    With oCom
      .Shape.TextFrame.AutoSize = True
      If .Shape.Width > 300 Then
        lArea = .Shape.Width * .Shape.Height
        .Shape.Width = 200
        .Shape.Height = (lArea / 200) * 1.1
      End If
    End With
  Next oCom
End Sub

 

[DanteAmor]

Thank you @JoeMo for the great idea, let's take advantage of that code and integrate it into mine.

Sub insert_comments()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long
  Dim f As Range
  Dim serial As String
  Dim lArea As Double
  
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  
  For i = 30 To sh1.Range("A" & Rows.Count).End(3).Row
    serial = sh1.Range("A" & i).Value
    Set f = sh2.Range("B:B").Find(serial, , xlValues, xlPart, , , False)
    If Not f Is Nothing Then
      With sh1.Range("B" & i)
        If Not .Comment Is Nothing Then .ClearComments
        .AddComment
        With .Comment
          .Shape.TextFrame.AutoSize = True
          .Visible = True
          .Text Text:=Mid(f.Value, Len(serial) + 1)
          DoEvents
          If .Shape.Width > 200 Then
            lArea = .Shape.Width * .Shape.Height
            .Shape.Width = 200
            .Shape.Height = (lArea / 200) + 10
          End If
        End With
      End With
    End If
  Next
End Sub

 

[aashish83]

Thank you @JoeMo for the great idea, let's take advantage of that code and integrate it into mine.

Sub insert_comments()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long
  Dim f As Range
  Dim serial As String
  Dim lArea As Double
 
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
 
  For i = 30 To sh1.Range("A" & Rows.Count).End(3).Row
    serial = sh1.Range("A" & i).Value
    Set f = sh2.Range("B:B").Find(serial, , xlValues, xlPart, , , False)
    If Not f Is Nothing Then
      With sh1.Range("B" & i)
        If Not .Comment Is Nothing Then .ClearComments
        .AddComment
        With .Comment
          .Shape.TextFrame.AutoSize = True
          .Visible = True
          .Text Text:=Mid(f.Value, Len(serial) + 1)
          DoEvents
          If .Shape.Width > 200 Then
            lArea = .Shape.Width * .Shape.Height
            .Shape.Width = 200
            .Shape.Height = (lArea / 200) + 10
          End If
        End With
      End With
    End If
  Next
End Sub

Thank so very much Dante & Jo you guys Rock....it worked like a charm!

 

[DanteAmor]

Glad we could help & thanks for the feedback