Insert Row/Copy with Autofilter

[lilbit3684]

I have a macro that copies the active cell's row and pastes it in the row
below it. It then deletes certain columns of data from the new row that was
pasted. However, I've noticed that it does not work when I the data is
filtered. It only inserts a blank row. Is there any way to get this to work
with the data filtered?

Sub InsertRowCopyDownwDelete()

ActiveSheet.Unprotect

ActiveCell.EntireRow.Select
Selection.Copy
ActiveCell.Offset(1, 0).EntireRow.Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False

Dim ClearRange As Range
Dim Area As Range
Dim RowNumber As Variant

Set ClearRange = Range("I:I,L:L,N,TK")
RowNumber = ActiveCell.Row
If RowNumber > 1 Then
For Each Area In ClearRange.Areas
Area.Rows(RowNumber).ClearContents
Next Area
End If
ActiveCell.Activate

Set ClearRange = Nothing
Set Area = Nothing

ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowInsertingRows:=True, AllowInsertingHyperlinks:=True,
AllowFiltering _
:=True


End Sub

 

[Barb Reinhardt]

Try this:

Sub InsertRowCopyDownwDelete()
Dim aWS As Worksheet
Dim ClearRange As Range
Dim Area As Range
Dim RowNumber As Variant

Set aWS = ActiveSheet

aWS.Unprotect

ActiveCell.EntireRow.Copy
ActiveCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
ActiveCell.Offset(1, 0).EntireRow.Hidden = False

'Application.CutCopyMode = False


Set ClearRange = Range("I:I,L:L,N,TK")
RowNumber = ActiveCell.Row
If RowNumber > 1 Then
For Each Area In ClearRange.Areas
Area.Rows(RowNumber).ClearContents
Next Area
End If
ActiveCell.Activate

Set ClearRange = Nothing
Set Area = Nothing

ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowInsertingRows:=True, AllowInsertingHyperlinks:=True,
AllowFiltering _
:=True


End Sub

 

[lilbit3684]

Still just inserted a blank row...

Try this:

Sub InsertRowCopyDownwDelete()
Dim aWS As Worksheet
Dim ClearRange As Range
Dim Area As Range
Dim RowNumber As Variant

Set aWS = ActiveSheet

aWS.Unprotect

ActiveCell.EntireRow.Copy
ActiveCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
ActiveCell.Offset(1, 0).EntireRow.Hidden = False

'Application.CutCopyMode = False


Set ClearRange = Range("I:I,L:L,N,TK")
RowNumber = ActiveCell.Row
If RowNumber > 1 Then
For Each Area In ClearRange.Areas
Area.Rows(RowNumber).ClearContents
Next Area
End If
ActiveCell.Activate

Set ClearRange = Nothing
Set Area = Nothing

ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowInsertingRows:=True, AllowInsertingHyperlinks:=True,
AllowFiltering _
:=True


End Sub

 

[Barb Reinhardt]

Have it print out the Activecell.address to see if you are copying what you
think you are copying. I didn't have a problem with it.

 

[David McRitchie]

Worked for me also, even if I filtered on column after selecting
an active cell, but you indicated that you wanted to clear the
areas on the inserted row and the macro was written
to clear areas on the inserted row below the active cell.
You could just put the range of columns in the clearContents
rather than making a variable, but I would certainly eliminate
the loop.

I used Barb's version to test, since you indicated you tested
it as well.

' Use this code without a loop
If RowNumber > 1 Then
Intersect(ActiveCell.Offset(1, 0).EntireRow, ClearRange).ClearContents
End If

'instead of this code...
If RowNumber > 1 Then
For Each Area In ClearRange.Areas
Area.Rows(RowNumber).ClearContents '<--- forgot the offset
Next Area
End If

Suggest you color your active cell for testing before running macro,
you can even without changing the active cell filter on
another column. After you run the macro unprotect the sheet
and show all rows (turn off filter).

I can send you my test file, I simply use MarkCells
to create data see MarkCells in
http://www.mvps.org/dmcritchie/excel/join.htm#markcells
http://www.mvps.org/dmcritchie/excel/code/join.txt for code
to fill in all cells modified a column for filtering, colored that
activecell and then invoked the filter.