Macros - Auto Copy paste row when cell value changes

[Hema12]

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.


[TABLE="width: 471"]
<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>[TR]
[TD="width: 109, bgcolor: #EDBA3B"]Office[/TD]
[TD="width: 86, bgcolor: #EDBA3B"]Date OT
Worked[/TD]
[TD="width: 78, bgcolor: #EDBA3B"]Title[/TD]
[TD="width: 91, bgcolor: #EDBA3B"]Last Name[/TD]
[TD="width: 89, bgcolor: #EDBA3B"]First Name[/TD]
[TD="width: 67, bgcolor: #EDBA3B"]Number of Hours[/TD]
[TD="width: 106, bgcolor: #EDBA3B"]Justification
for OT
[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"] [/TD]
[TD] [/TD]
[TD="bgcolor: transparent"] [/TD]
[TD] [/TD]
[TD="bgcolor: transparent"] [/TD]
[TD] [/TD]
[TD]when data is entered here,
macro copies this row and pastes below this row
[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, colspan: 5"]Total Hours
[/TD]
[TD="bgcolor: transparent"] [/TD]
[TD="bgcolor: transparent"] [/TD]
[/TR]
</tbody>[/TABLE]


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!

 

[mumps]

Try:

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

 

[Fluff]

How about

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]

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]

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]

Change the password to suit

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

 

[Hema12]

It worked! Thank you so much!

 

[Fluff]

You're welcome & thanks for the feedback