Macro to allow for inserting rows & maintain conditional format ranges

Hello,
I know this problem has been discussed at length before and I've never seen a workaround - at least none that I can remember.
I've been working on this problem for years and last summer I came across a couple of key bits of information.
I been able get a working solution - but it is limited to SINGLE row selected.
I feel pretty confident that what I want to do can be done, but I'm not savvy enough to get it working fully.

The entire concept rests on a Two Key functions:
1> the Insert Rows function leaves the Ranges in the "applies to" part of a conditional format intact by expanding the range!

The inserted rows must be blank - can't be copied

2> using VBA to "paste special Paste:=xlPasteFormats" does NOT include the conditional formatting.

This is the OPPOSITE of paste special "formats" and "Copy & insert copied cells" when done from the user interface.

Macro workflow:
User makes selection of rows (could be full rows or just within a set of columns - this is key if the worksheet is locked because full rows can't be selected).
User runs Macro

(Not present in current macro, but it should check that the selection set is a contiguous set of rows)

Macro creates a selection that = the entire rows of the selected cells.
IF Selection is 'nothing'

Count the number of rows
Use normal 'insert rows' and insert the same number of rows as the user selected

Else

Count the number of rows
Define the entire rows of the user selection as a range to reference, and return to
Insert the same number of rows as the user selection
Use a loop to check every cell of the user range and then copy
There are two steps to the copy function:

If Formula - then copy the formula

Always copy the formats

Final step is to return the user to the original selection or the rows of the original selection which allows the user to run the Macro again on the same set of data

Sub Macro_Insert_Row_test5() ' Insert_And_Copy Macro - keep conditional formatting ranges intact.

Dim PrevRow As Range
Dim CurrentRow As Range
Dim NextRow As Range
Dim FirstRow As Long
Dim LastRow As Long
Dim TotalRows As Long

Set CurrentRow = Selection.EntireRow                ' Create the data set to be copied
FirstRow = Selection.Row                            ' First row of user selected data
LastRow = Selection.Row + Selection.Rows.Count - 1  ' Last row of user selected data
TotalRows = LastRow - FirstRow + 1                  ' Total number of rows in User Selected data
Set ValueTest = ActiveSheet.UsedRange               ' Debugging value to follow the 'is nothing' comparator

Application.ScreenUpdating = False                  ' keep screen update clean and speed up code
Application.CutCopyMode = False                     ' keep the clipboard free of large data sets - usefulness un-confirmed

    If Intersect(ActiveSheet.UsedRange, Selection.Offset(1, 0).EntireRow) Is Nothing Then   ' If the selection is blank, copy and insert as normal
            Selection.EntireRow.Insert Shift:=xlDown
            MsgBox "I copied a blank row" 'for testing - commented out in normal use
    Else
        If TotalRows > 1 Then       '   If Selection.Rows.Count Greater than 1 row Then
            MsgBox "More than one row selected." & vbCrLf & FirstRow & " " & LastRow & " " & TotalRows ' Report the coniditon to user - this would be skipped in final code
            Rows(FirstRow & ":" & LastRow).Offset(TotalRows).Insert Shift:=xlDown                      ' insert the same number of rows as the selection
            
            '   need help here
            
        Else         ' If only a single row - continue with code below
        
            Set PrevRow = ActiveCell.EntireRow          ' Set Variable
            PrevRow.Offset(1, 0).EntireRow.Insert       ' Insert BELOW the row
            For Each Cell In Intersect(ActiveSheet.UsedRange, Selection.EntireRow)
                Cell.Copy                                                  ' Copy current active cell contents
                If Cell.HasFormula Then                                    ' Check for formula
                    Cell.Offset(1, 0).PasteSpecial Paste:=xlPasteFormulas  ' ONLY paste formula if yes
                    MsgBox "I copied formula"                              ' for testing - commented out in normal use
                End If
            Cell.Offset(1, 0).PasteSpecial Paste:=xlPasteFormats       ' Paste formats - testing indicates that this excludes conditonal formatting
            Next Cell
        End If
    End If

    CurrentRow.Select       ' Set the current row to use command again
          
End Sub

You will notice that there is an additional check in the actual code, and that is to check if there is more than 1 row selected, this is because I couldn't figure out to get the copy.cell code to work when there needed to be an offset.
I assume that in the final code, I would not need this code because the structure wouldn't care how many rows were selected.

The first check (If nothing) is purely to keep things moving faster if the cells are blank.

I hope that this not hard to solve, and it would just take someone who knows how to write the syntax to copy a cell and then paste it down by the right number of rows.

Thanks for your help!
This macro really keeps things clean when conditional formats are used.



Regards,

SEPP!

Ok.... I think I solved my own problem...
In which case - Please feel free to use and share!
If anyone is inclined, I'd love to find out if there was a way to speed this up...

Current version of my code:

Sub Macro_Insert_Row_test6() ' Insert_And_Copy Macro - keep condintional formatting ranges intact.
' Written by Sepp Spenlinhauer with various extensive reseach from multiple online excel websites

Dim PrevRow As Range
Dim CurrentRow As Range
Dim NextRow As Range
Dim FirstRow As Long
Dim LastRow As Long
Dim TotalRows As Long

Set CurrentRow = Selection.EntireRow                ' Create the data set to be copied
FirstRow = Selection.Row                            ' First row of user selected data
LastRow = Selection.Row + Selection.Rows.Count - 1  ' Last row of user selected data
TotalRows = LastRow - FirstRow + 1                  ' Total number of rows in User Selected data
Set ValueTest = ActiveSheet.UsedRange               ' Debugging value to follow the 'is nothing' comparator

Application.ScreenUpdating = False                  ' keep screen update clean and speed up code
Application.CutCopyMode = False                     ' keep the clipboard free of large data sets - usefulness un-confirmed

    If Intersect(ActiveSheet.UsedRange, Selection.Offset(1, 0).EntireRow) Is Nothing Then   ' If the selection is blank, copy and insert as normal
            Selection.EntireRow.Insert Shift:=xlDown
            MsgBox "I copied a blank row" 'for testing - commented out in normal use
    Else
        If TotalRows > 1 Then       '   If Selection.Rows.Count Greater than 1 row Then
            MsgBox "More than one row selected." & vbCrLf & FirstRow & " " & LastRow & " " & TotalRows  ' Report the coniditon to user - this would be skipped in final code
            Rows(FirstRow & ":" & LastRow).Offset(TotalRows).Insert Shift:=xlDown                       ' insert the same number of rows as the selection
            For Each Cell In Intersect(ActiveSheet.UsedRange, Selection.EntireRow)
                Cell.Copy                                                                               ' Copy current active cell contents
                If Cell.HasFormula Then                                                                 ' Check for formula
                    Cell.Offset(TotalRows, 0).PasteSpecial Paste:=xlPasteFormulas                       ' ONLY paste formula if yes
'                    MsgBox "I copied formula"                                                          ' for testing - commented out in normal use
                End If
            Cell.Offset(TotalRows, 0).PasteSpecial Paste:=xlPasteFormats       ' Paste formats - testing indicates that this excludes conditonal formatting
            Next Cell
            
        Else         ' If only a single row - continue with code below
        
            Set PrevRow = ActiveCell.EntireRow          ' Set Variable
            PrevRow.Offset(1, 0).EntireRow.Insert       ' Insert BELOW the row
            For Each Cell In Intersect(ActiveSheet.UsedRange, Selection.EntireRow)
                Cell.Copy                                                  ' Copy current active cell contents
                If Cell.HasFormula Then                                    ' Check for formula
                    Cell.Offset(1, 0).PasteSpecial Paste:=xlPasteFormulas  ' ONLY paste formula if yes
                    MsgBox "I copied formula"                              ' for testing - commented out in normal use
                End If
            Cell.Offset(1, 0).PasteSpecial Paste:=xlPasteFormats       ' Paste formats - testing indicates that this excludes conditonal formatting
            Next Cell
        End If
    End If

    CurrentRow.Select       ' Set the current row to use command again
          
End Sub

Ok, Update number three.

I have uploaded a file with the macro and an example of one worksheet.
The sheet will pretty much give you nothing but errors because almost every part of it is linked to about 20 other sheets, but you should be able to understand the value of this macro...
As an example, click on an single 'sub-row' (or any single cell in a row) in a area and run the macro - the formulas will copy but the data will not - and the conditional format ranges will GROW! without getting fragmented.
Then Select a range of cells that includes the Area header row & the blank row at the end of that group.
Run the macro and you will see it copy the entire section, again formulas, validation and conditional formats but not the data.

(Compare running the macro to either inserting a blank row or copying and inserting the copied rows... - then check the conditional formats)...

I have this set as a quick access macro button, so running it is click simple!

New features added:

It became apparent today that there was a possible glitch with the way that the Data Validation was copying.
When the data validation was different on each row, the insert row command was setting the data validation to the same for cells that didn't have validation set before (Blank validation rules).
So I had to add a line to make sure that it also got copied correctly.

New additions:
User selection is checked to be contiguous.
User is asked to continue if they select more than one row.
Info box is redesigned for cleaner appearance & added a cancel button.
Data validations are properly copied.
Sheet is locked after code is completed.
There is a beep at the end of the code.

Current 'issues':
1> code finishes with a beep, but user still has to wait to regain interface control.
2> no Undo from Macro Run Command

Regards
SEPP!


Here is the current code:

Sub Macro_Insert_Row(control As IRibbonControl)
'
' Insert_And_Copy Macro - Keep Conditional Format ranges INTACT
' By Sepp Spenlinhauer - 2010 -> 2015
' Last update 2-16-2015

Dim PrevRow As Range
Dim CurrentRow As Range
Dim NextRow As Range
Dim FirstRow As Long
Dim LastRow As Long
Dim TotalRows As Long
Dim AskYN As Integer


Set CurrentRow = Selection.EntireRow                ' Create the data set to be copied
FirstRow = Selection.Row                            ' First row of user selected data
LastRow = Selection.Row + Selection.Rows.Count - 1  ' Last row of user selected data
TotalRows = LastRow - FirstRow + 1                  ' Total number of rows in User Selected data
Set ValueTest = ActiveSheet.UsedRange               ' Debugging value to follow the 'is nothing' comparator

Application.ScreenUpdating = False                  ' keep screen update clean and speed up code
Application.CutCopyMode = False                     ' keep the clipboard free of large data sets - usefulness un-confirmed

 '  Report the coniditon to user - this would be skipped in final code
     
     
    If Selection.Areas.Count > 1 Then
        MsgBox "Select a contiguous range only"
        Exit Sub
    End If
    
    If Intersect(ActiveSheet.UsedRange, Selection.Offset(1, 0).EntireRow) Is Nothing Then   ' If the selection is blank, copy and insert as normal
            Selection.EntireRow.Insert Shift:=xlDown
            MsgBox "I copied a blank row" 'for testing - commented out in normal use
    Else
        If TotalRows > 1 Then       '   If Selection.Rows.Count Greater than 1 row Then
            AskYN = MsgBox("More than one row selected." & vbCrLf & _
                    "First Row: " & FirstRow & vbCrLf & _
                    "Last Row: " & LastRow & vbCrLf & _
                    "Total Rows: " & TotalRows & vbCrLf & _
                    vbCrLf & vbCrLf & _
                    "Continue?", vbYesNo, "Continue?")
            If AskYN = vbYes Then
                ActiveSheet.Unprotect
                Rows(FirstRow & ":" & LastRow).Offset(TotalRows).Insert Shift:=xlDown                       ' insert the same number of rows as the selection
                For Each Cell In Intersect(ActiveSheet.UsedRange, Selection.EntireRow)
                    Cell.Copy                                                                               ' Copy current active cell contents
                    If Cell.HasFormula Then                                                                 ' Check for formula
                        Cell.Offset(TotalRows, 0).PasteSpecial Paste:=xlPasteFormulas                       ' ONLY paste formula if yes
    '                   MsgBox "I copied formula"                                                          ' for testing - commented out in normal use
                    End If
                Cell.Offset(TotalRows, 0).PasteSpecial Paste:=xlPasteFormats        ' Paste formats - testing indicates that this excludes conditional formatting
                Cell.Offset(TotalRows, 0).PasteSpecial Paste:=xlPasteValidation     ' Paste Validation
                Next Cell
            Else
                Exit Sub
            End If
        Else         ' If only a single row - continue with code below
            ActiveSheet.Unprotect
            Set PrevRow = ActiveCell.EntireRow          ' Set Variable
            PrevRow.Offset(1, 0).EntireRow.Insert       ' Insert BELOW the row
            For Each Cell In Intersect(ActiveSheet.UsedRange, Selection.EntireRow)
                Cell.Copy                                                  ' Copy current active cell contents
                If Cell.HasFormula Then                                    ' Check for formula
                    Cell.Offset(1, 0).PasteSpecial Paste:=xlPasteFormulas  ' ONLY paste formula if yes
'                    MsgBox "I copied formula"                             ' for testing - commented out in normal use
                End If
            Cell.Offset(1, 0).PasteSpecial Paste:=xlPasteFormats       ' Paste formats - testing indicates that this excludes conditonal formatting
            Cell.Offset(1, 0).PasteSpecial Paste:=xlPasteValidation    ' Paste Validation
            Next Cell
        End If
    End If

    CurrentRow.Select       ' Set the current row to use command again
    ActiveSheet.Protect _
        DrawingObjects:=True, _
        Contents:=True, _
        UserInterfaceOnly:=True

    ActiveSheet.EnableOutlining = True
    
    Beep
    
End Sub