Copy and paste as a comment from one Excel file to other Excel file

[BBCC0000]

Hi everyone,

I'm not sure Excel VBA can do this, so I'm posting it to ask. Hope you guys can spend a little time to help me on this

First step:
I have this Excel file (File A) which contains Number, Code and Your Name, and the name in cell E3. The name could be changed periodically (variable).

Second step:
I have another Excel file (File B) which contains many rows.

Third step:
I want file A copy their Code and paste to the matched Number of file B respectively as a COMMENT.
The name of the comment is from the file B cell E2.

I really appreciate if there is anyone who knows about this. Thanks for your help in advance!

 

[jolivanes]

Not tested.

Sub Maybe()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim nm As String, c As Range
Set sh1 = Workbooks("File_A_.xlsm").Sheets("Sheet1")    '<---- Change to actual
Set sh2 = Workbooks("File_B_.xlsm").Sheets("Sheet1")    '<---- Change to actual
nm = sh1.Range("E3").Value
    For Each c In sh1.Range("A2:A" & sh1.Cells(Rows.Count, 1).End(xlUp).Row)
        sh2.Columns(1).Find(c.Value).Offset(, 3).AddComment nm & vbLf & c.Offset(, 1).Value
    Next c
End Sub

 

[Georgiboy]

What I was working on:

Sub test()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rng As Range, rCell As Range, str As String, nm As String
    
    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
    Set rng = ws2.Range("A2:A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row)
    nm = ws1.Range("E3")
    
    For Each rCell In rng
        If Application.CountIf(ws1.Range("A:A"), rCell) > 0 Then
            str = Application.VLookup(rCell, ws1.Range("A:B"), 2, 0)
            With rCell.Offset(, 3)
                If Not .Comment Is Nothing Then .Comment.Delete
                .AddComment nm & vbNewLine & str
                .Comment.Shape.TextFrame.Characters(1, Len(nm)).Font.Bold = True
            End With
        End If
    Next rCell
End Sub

 

[BBCC0000]

What I was working on:

Sub test()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rng As Range, rCell As Range, str As String, nm As String
   
    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
    Set rng = ws2.Range("A2:A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row)
    nm = ws1.Range("E3")
   
    For Each rCell In rng
        If Application.CountIf(ws1.Range("A:A"), rCell) > 0 Then
            str = Application.VLookup(rCell, ws1.Range("A:B"), 2, 0)
            With rCell.Offset(, 3)
                If Not .Comment Is Nothing Then .Comment.Delete
                .AddComment nm & vbNewLine & str
                .Comment.Shape.TextFrame.Characters(1, Len(nm)).Font.Bold = True
            End With
        End If
    Next rCell
End Sub

Since I am using two different Excel file, should I define their locations first?

 

[Georgiboy]

Yes sorry neglected the fact you are using separate workbooks, try updating as below where the workbook/ sheet names need to be updated:

    Set ws1 = Workbooks("Book1.xlsx").Sheets("Sheet1")
    Set ws2 = Workbooks("Book2.xlsx").Sheets("Sheet1")

 

[BBCC0000]

Yes sorry neglected the fact you are using separate workbooks, try updating as below where the workbook/ sheet names need to be updated:

    Set ws1 = Workbooks("Book1.xlsx").Sheets("Sheet1")
    Set ws2 = Workbooks("Book2.xlsx").Sheets("Sheet1")

Also, "If Not .Comment Is Nothing Then .Comment.Delete" means if it is not available in ws1 then it will be deleted? Because it may have other comments that aren't supposed to be deleted if not found in ws1.

One more question: Can the comment size autofit according to the words inside? For example I want it to be length 100 but width adjusted to its words inside.

 

[Georgiboy]

It will only delete a comment for an item it has found, to resize the comment box, try as below:

Sub test()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rng As Range, rCell As Range, str As String, nm As String
    
    Set ws1 = Workbooks("Book1.xlsx").Sheets("Sheet1")
    Set ws2 = Workbooks("Book2.xlsx").Sheets("Sheet1")
    
    Set rng = ws2.Range("A2:A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row)
    nm = ws1.Range("E3")
    
    For Each rCell In rng
        If Application.CountIf(ws1.Range("A:A"), rCell) > 0 Then
            str = Application.VLookup(rCell, ws1.Range("A:B"), 2, 0)
            With rCell.Offset(, 3)
                If Not .Comment Is Nothing Then .Comment.Delete
                .AddComment nm & vbNewLine & str
                With .Comment.Shape.TextFrame
                    .Characters(1, Len(nm)).Font.Bold = True
                    .AutoSize = True
                End With
            End With
        End If
    Next rCell
End Sub

 

[BBCC0000]

It will only delete a comment for an item it has found, to resize the comment box, try as below:

Sub test()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rng As Range, rCell As Range, str As String, nm As String
   
    Set ws1 = Workbooks("Book1.xlsx").Sheets("Sheet1")
    Set ws2 = Workbooks("Book2.xlsx").Sheets("Sheet1")
   
    Set rng = ws2.Range("A2:A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row)
    nm = ws1.Range("E3")
   
    For Each rCell In rng
        If Application.CountIf(ws1.Range("A:A"), rCell) > 0 Then
            str = Application.VLookup(rCell, ws1.Range("A:B"), 2, 0)
            With rCell.Offset(, 3)
                If Not .Comment Is Nothing Then .Comment.Delete
                .AddComment nm & vbNewLine & str
                With .Comment.Shape.TextFrame
                    .Characters(1, Len(nm)).Font.Bold = True
                    .AutoSize = True
                End With
            End With
        End If
    Next rCell
End Sub

Thanks! Finally I know how to autosize the comment

Can they arrange the comment automatically too?

For example, all comments move to row G, from A to E, from up to down. If there are 2 comments within the same row, arrange whoever comes first (refer example row 8), and they align within their same row (if the upper comment exceeds the other row, the row's comment shall move to its bottom).

 

[Georgiboy]

In my opinion this could get messy but give the below a try:

Sub test()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rng As Range, rCell As Range, str As String, nm As String
    Dim cTop As Long, cLeft As Long
    
    Set ws1 = Workbooks("Book1.xlsx").Sheets("Sheet1")
    Set ws2 = Workbooks("Book2.xlsx").Sheets("Sheet1")
    
    Set rng = ws2.Range("A2:A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row)
    nm = ws1.Range("E3")

    For Each rCell In rng
        If Application.CountIf(ws1.Range("A:A"), rCell) > 0 Then
            str = Application.VLookup(rCell, ws1.Range("A:B"), 2, 0)
            With rCell.Offset(, 3)
                If Not .Comment Is Nothing Then .Comment.Delete
                .AddComment nm & vbNewLine & str
                With .Comment.Shape.TextFrame
                    .Characters(1, Len(nm)).Font.Bold = True
                    .AutoSize = True
                End With
            End With
        End If
    Next rCell
    
    Set rng = rng.Resize(, 5)
    cTop = rng.SpecialCells(xlCellTypeComments)(1).Comment.Shape.Top
    cLeft = ws2.Range("G1").Left
    For Each rCell In rng.Cells
        With rCell
            If Not .Comment Is Nothing Then
                .Comment.Visible = True
                .Comment.Shape.Top = cTop
                .Comment.Shape.Left = cLeft
                cTop = .Comment.Shape.Top + .Comment.Shape.Height
            End If
        End With
    Next rCell
End Sub

 

[BBCC0000]

What I was working on:

Sub test()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rng As Range, rCell As Range, str As String, nm As String
   
    Set ws1 = Workbooks("Book1.xlsx").Sheets("Sheet1")
    Set ws2 = Workbooks("Book2.xlsx").Sheets("Sheet1")
    Set rng = ws2.Range("A2:A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row)
    nm = ws1.Range("E3")
   
    For Each rCell In rng
        If Application.CountIf(ws1.Range("A:A"), rCell) > 0 Then
            str = Application.VLookup(rCell, ws1.Range("A:B"), 2, 0)
            With rCell.Offset(, 3)
                If Not .Comment Is Nothing Then .Comment.Delete
                .AddComment nm & vbNewLine & str
                .Comment.Shape.TextFrame.Characters(1, Len(nm)).Font.Bold = True
            End With
        End If
    Next rCell
End Sub

Hi, I tried this macro but it shows "Subscript Out of Range (Run-Time Error '9')". Do you have any ideas on this?