VBA to Copy and Paste values to same row range in same sheet based on a Trigger

RaginMuse

New Member
Joined
Feb 23, 2023
Messages
7
Office Version
  1. 365
Platform
  1. MacOS
I'm fairly new to VBA and I'm hoping I could get some help here to achieve what I'm trying to do. I've searched and read through, and a lot of solutions are about copying and pasting from one sheet to another.
Basically, I want to Copy and Paste the Values in the same row range based on a trigger from another column in the same Sheet.

I've Column G with the trigger word, which is "Hired"; I've data range J5:AG436 For example, if G11 is "Hired", I want the existing data in J11:AG11 to be copied and pasted as Values.

Here's a code that I'm trying to use but got nowhere with it. Perhaps this is not it?

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim triggerColumn As Long
triggerColumn = 7 ' column G is the trigger column
Dim triggerWord As String
triggerWord = "Hired" ' the trigger word to look for
   
'define range to which the code will be applied
Dim dataRange As Range
Set dataRange = Me.Range("J11:AG436") 'change to match the range of your data
   
If Not Intersect(Target, dataRange) Is Nothing Then
' a cell within the data range was changed
If Target.Column = triggerColumn Then
' the trigger column was changed
If InStr(1, Target.Value, triggerWord, vbTextCompare) > 0 Then
' the trigger word was found in the changed cell
' copy and paste special values from the current cell
                Target.Copy
                Target.PasteSpecial xlPasteValues
End If
End If
End If
End Sub

Any help is greatly appreciated.
 

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.
Hello RaginMuse,

I'm not sure where you want to paste to, so I've assumed Sheet2, Column A is the destination:-

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, Columns(7)) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Target.Value = vbNullString Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
          trow = Target.Row
          If Target.Value = "Hired" Then
                Range(Cells(trow, "J"), Cells(trow, "AG")).Copy
                Sheet2.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlValues
          End If
    
    Application.EnableEvents = True
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

I hope that this helps.

Cheerio,
vcoolio.
 
Upvote 1
Thank you for your assistance, Vcoolio.
I want to copy and paste in the same row, not a different sheet.
 
Upvote 0
Try:
PHP:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("G11:G436")) Is Nothing Or Target.Value <> "Hired" Or Target.Count > 1 Then Exit Sub
Application.EnableEvents = False
With Range(Cells(Target.Row, "J"), Cells(Target.Row, "AG"))
    .Value = .Value
End With
Application.EnableEvents = True
End Sub
 
Upvote 1
Try:
PHP:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("G11:G436")) Is Nothing Or Target.Value <> "Hired" Or Target.Count > 1 Then Exit Sub
Application.EnableEvents = False
With Range(Cells(Target.Row, "J"), Cells(Target.Row, "AG"))
    .Value = .Value
End With
Application.EnableEvents = True
End Sub
It's not working for me.
The solution from Vcoolio is working, except I want the copied range to be pasted in the exact same range but as Values.
Thanks for your help
 
Upvote 0
VBA Test Sheet.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAG
7No.DivisionDepartmentDesignation LevelNumberStatusMonth to onboardMonthJan-23Feb-23Mar-23Apr-23May-23Jun-23Jul-23Aug-23Sep-23Oct-23Nov-23Dec-23Jan-24Feb-24Mar-24Apr-24May-24Jun-24Jul-24Aug-24Sep-24Oct-24Nov-24Dec-24
81Food & BeverageF&B CulinaryCommis IL5Xx2Aug-23-------11111111111111111
92Food & BeverageF&B CulinaryCommis IL5Xx2Aug-23-------11111111111111111
103Food & BeverageF&B CulinaryCommis IL5Xx2Aug-23-------11111111111111111
Rampup 23 & 24
Cell Formulas
RangeFormula
J7J7=F1
K7:AG7K7=EDATE(J7,1)
J8:AG10J8=IF(AND(J$6<=$H8,$H8<>0),1,0)
Cells with Conditional Formatting
CellConditionCell FormatStop If True
H8:AG24,BF8:PY24,QA8:QM24,QO8:RA24Cell Value=0textNO
 
Upvote 0
VBA Test Sheet.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAG
7No.DivisionDepartmentDesignation LevelNumberStatusMonth to onboardMonthJan-23Feb-23Mar-23Apr-23May-23Jun-23Jul-23Aug-23Sep-23Oct-23Nov-23Dec-23Jan-24Feb-24Mar-24Apr-24May-24Jun-24Jul-24Aug-24Sep-24Oct-24Nov-24Dec-24
81Food & BeverageF&B CulinaryCommis IL5Xx2Aug-23-------11111111111111111
92Food & BeverageF&B CulinaryCommis IL5Xx2Aug-23-------11111111111111111
103Food & BeverageF&B CulinaryCommis IL5Xx2Aug-23-------11111111111111111
Rampup 23 & 24
Cell Formulas
RangeFormula
J7J7=F1
K7:AG7K7=EDATE(J7,1)
J8:AG10J8=IF(AND(J$6<=$H8,$H8<>0),1,0)
Cells with Conditional Formatting
CellConditionCell FormatStop If True
H8:AG24,BF8:PY24,QA8:QM24,QO8:RA24Cell Value=0textNO
Column G is where the trigger is.
 
Upvote 0
Hello RaginMuse,

I'm not sure why Bebo's code doesn't work for you. However, try the following version:-
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, Columns(7)) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Target.Value = vbNullString Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
          trow = Target.Row
          If Target.Value = "Hired" Then
               With Me.Range(Cells(trow, "J"), Cells(trow, "AG"))
                      .Value = .Value
               End With
          End If
    
    Application.EnableEvents = True
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub


I hope that this helps.

Cheerio,
vcoolio.
 
Upvote 0
Hello RaginMuse,

I'm not sure why Bebo's code doesn't work for you. However, try the following version:-
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, Columns(7)) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Target.Value = vbNullString Then Exit Sub
   
    Application.ScreenUpdating = False
    Application.EnableEvents = False
   
          trow = Target.Row
          If Target.Value = "Hired" Then
               With Me.Range(Cells(trow, "J"), Cells(trow, "AG"))
                      .Value = .Value
               End With
          End If
   
    Application.EnableEvents = True
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub


I hope that this helps.

Cheerio,
vcoolio.
Thank you, this works magic!! How could I add a warning before the event happens; just to ensure everyone else using the file knows the action will not be reversible? Thanks again for all your help!!
I don't know why Bebo's code didn't work either, I must have done something wrong for sure.
 
Upvote 0
Hello RaginMuse,

The code amended as follows with a message box pop-up might suffice. You can change the actual message to suit your needs if you like.

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim Warning As String
    
    If Intersect(Target, Columns(7)) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Target.Value = vbNullString Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Warning = MsgBox("Be warned that the action you are about to take is irreversible. To continue, click OK.", vbCritical + vbOKCancel, "WARNING")
          If Warning = vbOK Then
                trow = Target.Row
                If Target.Value = "Hired" Then
                     With Me.Range(Cells(trow, "J"), Cells(trow, "AG"))
                            .Value = .Value
                     End With
                     Else: Exit Sub
                End If
          End If
          
    Application.EnableEvents = True
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

I hope that this helps.

Cheerio,
vcoolio.
 
Upvote 1
Solution

Forum statistics

Threads
1,223,236
Messages
6,170,912
Members
452,366
Latest member
TePunaBloke

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top