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!



 

Some videos you may like

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,743
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:

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
48,216
Office Version
  1. 365
Platform
  1. Windows
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
 

Hema12

New Member
Joined
Aug 27, 2019
Messages
4
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!
 

Hema12

New Member
Joined
Aug 27, 2019
Messages
4

ADVERTISEMENT

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?


 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
48,216
Office Version
  1. 365
Platform
  1. Windows
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
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
48,216
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback
 

Watch MrExcel Video

Forum statistics

Threads
1,114,232
Messages
5,546,643
Members
410,752
Latest member
MC01_
Top