Macros - Auto Copy paste row when cell value changes

Hema12

New Member
Joined
Aug 27, 2019
Messages
4


I am not very experienced with excel so need help to do thefollowing:

I have column headers in columns A:G In the row below I have blankcells for data input. When column g has text input, I want a macro toautomatically copy the row (sans data but keep formulas and formatting) and paste in the row below.

For exampleif data is entered in G3, macro should copy row 3, insert and paste in row 4,delete contents of copied data in row 4. This sequence should repeat each timedata is entered in any cell in column G. The very last row has formulas tocalculate totals.


OfficeDate OT
Worked
TitleLast NameFirst NameNumber of HoursJustification
for OT

when data is entered here,
macro copies this row and pastes below this row
Total Hours
<colgroup><col width="109" style="width: 82pt; mso-width-source: userset; mso-width-alt: 3986;"> <col width="86" style="width: 65pt; mso-width-source: userset; mso-width-alt: 3145;"> <col width="78" style="width: 59pt; mso-width-source: userset; mso-width-alt: 2852;"> <col width="91" style="width: 68pt; mso-width-source: userset; mso-width-alt: 3328;"> <col width="89" style="width: 67pt; mso-width-source: userset; mso-width-alt: 3254;"> <col width="67" style="width: 50pt; mso-width-source: userset; mso-width-alt: 2450;"> <col width="106" style="width: 80pt; mso-width-source: userset; mso-width-alt: 3876;"> <tbody> </tbody>


I have the following macro to copy, insert row, and paste:

Sub InsertRow() '
' InsertRow Macro '
' ActiveCell.EntireRow.SelectSelection.Copy Selection.Insert Shift:=xlDown
On Error Resume NextActiveCell.Offset(1, 0).EntireRow.Cells.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0 ActiveCell.Offset(1, 0).Select Application.CutCopyMode = False
End Sub

I have the following macro to autorun the insert macro when the value incolumn G changes:

Private Sub Worksheet_Change(ByVal Target As Range)
IfTarget.Address = "$G$4"
Then Application.EnableEvents = False
InsertRow
Application.EnableEvents = True
End If
End Sub

Those work only when Ichange value in G4 however if I try to change the macro to apply to all ofcolumn G the macro goes crazy. I am unsure how to modify macro to run for theentire column G.

Thank you in advance for any suggestions or assistance!



 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Try:
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("G:G")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Rows(Target.Row + 1).Insert
    Target.EntireRow.Copy
    With Rows(Target.Row + 1)
        .PasteSpecial Paste:=xlPasteFormats
        .PasteSpecial Paste:=xlPasteFormulas
        .SpecialCells(xlCellTypeConstants).ClearContents
    End With
    Application.CutCopyMode = False
    Application.EnableEvents = True
End Sub
 
Last edited:
Upvote 0
How about
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.CountLarge > 1 Then Exit Sub
   If Not Intersect(Target, Range("[COLOR=#ff0000]G2:G100[/COLOR]")) Is Nothing Then
      Application.EnableEvents = False
      Target.EntireRow.Copy
      Rows(Target.Row + 1).Insert
      On Error Resume Next
      Target.Offset(1).EntireRow.SpecialCells(xlConstants).ClearContents
      On Error GoTo 0
      Application.EnableEvents = True
   End If
End Sub
Change part in red to suit
 
Upvote 0
OMG! That worked! I've been trying to figure this out for days and that code isn't even super complicated. Thank you so much!
 
Upvote 0
Ok so aftertrying the codes provided
Mumps: your code works however if the userdeletes the contents of the cell, code error pops up
Fluff: your code works also however I getan error code when I try it with the sheet protected.

Any more suggestions please?


 
Upvote 0
Change the password to suit
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.CountLarge > 1 Then Exit Sub
   If Not Intersect(Target, Range("G:G")) Is Nothing Then
      Application.EnableEvents = False
      Me.Unprotect "[COLOR=#ff0000]pword[/COLOR]"
      Target.EntireRow.Copy
      Rows(Target.Row + 1).Insert
      On Error Resume Next
      Target.Offset(1).EntireRow.SpecialCells(xlConstants).ClearContents
      On Error GoTo 0
      Me.Protect "[COLOR=#ff0000]pword[/COLOR]"
      Application.EnableEvents = True
   End If
End Sub
 
Upvote 0
You're welcome & thanks for the feedback
 
Upvote 0

Forum statistics

Threads
1,213,550
Messages
6,114,265
Members
448,558
Latest member
aivin

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