Results 1 to 4 of 4
  1. #1
    New Lounger kyokuma_jr's Avatar
    Join Date
    Feb 2016
    Posts
    2
    Thanks
    0
    Thanked 0 Times in 0 Posts

    VBA - find matches, then copy/paste comments

    Was trying to look through old posts, but none worked.

    I need to compare values from column "B" Sheet1 to values in column "A" Sheet2.
    If any match, then copy the comments from sheet2 column A cells, & paste the comments into the corresponding cells in Sheet1 column B cells.

    Thank you.

  2. #2
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,434
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    kyokuma_jr

    Welcome to the Lounge as a New Poster!

    This should do what you want:
    Code:
     Option Explicit
    
    Sub CopyComments()
    
       Dim lCurRow   As Long
       Dim lHit      As Long
       Dim shtSource As Worksheet
       Dim shtDest   As Worksheet
       Dim cmt       As Comment
       Dim zHoldCmt  As String
       
       Set shtDest = ActiveWorkbook.Sheets("Sheet1")
       Set shtSource = ActiveWorkbook.Sheets("Sheet2")
       
       shtDest.Activate
       lCurRow = 2
       lHit = 0
       
       Do
         On Error Resume Next
         lHit = WorksheetFunction.Match(Cells(lCurRow, 2), shtSource.Range("A:A"), 0)
         On Error GoTo 0
         
         If lHit > 0 Then
          
           Set cmt = shtSource.Cells(lHit, 1).Comment
           
           If Not (cmt Is Nothing) Then
             zHoldCmt = shtSource.Cells(lHit, 1).Comment.Text
             Set cmt = shtDest.Cells(lCurRow, 2).Comment
             
             If (cmt Is Nothing) Then
               Set cmt = shtDest.Cells(lCurRow, 2).AddComment
             End If
             
               cmt.Text Text:=zHoldCmt
               
           End If
          
           lHit = 0
           
         End If
         
         lCurRow = lCurRow + 1
         
       Loop Until Cells(lCurRow, 2) = ""
       
    End Sub
    Here's a my test file: Excel - VBA - Copy Comments.xlsm

    If you have any questions about the code please post back.

    HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  3. #3
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,434
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    kyokuma_jr

    Here's a commented version I should have done the first time.
    Code:
    Option Explicit
    
    Sub CopyComments()
    
       Dim lCurRow   As Long
       Dim lHit      As Long
       Dim shtSource As Worksheet
       Dim shtDest   As Worksheet
       Dim cmt       As Comment
       Dim zHoldCmt  As String
       
       Set shtDest = ActiveWorkbook.Sheets("Sheet1")
       Set shtSource = ActiveWorkbook.Sheets("Sheet2")
       
       shtDest.Activate
       lCurRow = 2       'Starting row in the Destination sheet.
       lHit = 0          'Initialize the found match variable
       
       Do
         On Error Resume Next
         lHit = WorksheetFunction.Match(Cells(lCurRow, 2), _
                                  shtSource.Range("A:A"), 0)
         On Error GoTo 0
         
         If lHit > 0 Then
           'Check for comment in matched source cell
           Set cmt = shtSource.Cells(lHit, 1).Comment
           
           If Not (cmt Is Nothing) Then
             'Save the found comment text
             zHoldCmt = shtSource.Cells(lHit, 1).Comment.Text
             'Check for existing comment in Destination cell
             Set cmt = shtDest.Cells(lCurRow, 2).Comment
             
             If (cmt Is Nothing) Then             'If no comment add one
               Set cmt = shtDest.Cells(lCurRow, 2).AddComment
             End If
             
               cmt.Text Text:=zHoldCmt  'Place comment text in destination comment
               
           End If
          
           lHit = 0   'Reset found match status!
           
         End If
         
         lCurRow = lCurRow + 1  'Move to next Destination row.
         
         'Loop until next cell is blank
         'assumes there are no blank lines in your destination sheet!
         
       Loop Until Cells(lCurRow, 2) = ""
       
    End Sub     'CopyComments
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  4. #4
    New Lounger kyokuma_jr's Avatar
    Join Date
    Feb 2016
    Posts
    2
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Thanks a lot Retired. It worked great.

    Long-time lurker, just finally registered.
    Last edited by RetiredGeek; 2016-02-13 at 11:48.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •