Energizey
10-16-2018, 08:15 PM
Hi All,
I am very new to VBA and would be super grateful for help with some code I am trying to make work.
I need the code to do the following -
From Source range E19:E29 look for exact match to values in Destination range A4:A55,
When exact match is found copy the values from Source range F19:Q29 and paste values to Destination range F4:Q55.
From Source range E33:E43 look for exact match to values in Destination range A101:A146,
When exact match is found copy the values from Source range F33:Q43 and paste values to Destination range F101:Q146.
The code I have found and adapted from the internet is as follows - I have only tried to tackle actions 1 and 2 above so far:
Option Explicit
Sub SubmitSubModalityBudget()
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("Karisma Raw Data Sheet")
Set shtSource = ActiveWorkbook.Sheets("Revenue_Services Calculation")
shtDest.Activate
lCurRow = 4 '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("E19:E29"), 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
I am very new to VBA and would be super grateful for help with some code I am trying to make work.
I need the code to do the following -
From Source range E19:E29 look for exact match to values in Destination range A4:A55,
When exact match is found copy the values from Source range F19:Q29 and paste values to Destination range F4:Q55.
From Source range E33:E43 look for exact match to values in Destination range A101:A146,
When exact match is found copy the values from Source range F33:Q43 and paste values to Destination range F101:Q146.
The code I have found and adapted from the internet is as follows - I have only tried to tackle actions 1 and 2 above so far:
Option Explicit
Sub SubmitSubModalityBudget()
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("Karisma Raw Data Sheet")
Set shtSource = ActiveWorkbook.Sheets("Revenue_Services Calculation")
shtDest.Activate
lCurRow = 4 '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("E19:E29"), 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