Dim RangeSelected As Variant
Dim PreviousRangeSelected As Variant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
PreviousRangeSelected = RangeSelected ' Save the previously selected range
RangeSelected = Target.Address(0, 0) ' Save the RangeSelected
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'
If Intersect(Target, Range("E3:E42")) Is Nothing And _
Intersect(Target, Range("F3:F42")) Is Nothing And _
Intersect(Target, Range("G3:G42")) Is Nothing And _
Intersect(Target, Range("M17:M36")) Is Nothing Then Exit Sub ' If change is not in our monitored range, Exit Sub
'
'-----------------------------------------------------------------------------------------------
'
Dim AddressCharacter As Long, EndAddressRow As Long
Dim SelectionRow As Long
Dim ActiveColumnLetter As String, LastMergedColumn As String
Dim EndDragColumnLetter As String, StartDragColumnLetter As String
Dim SelectionAddressArray As Variant
'
'-----------------------------------------------------------------------------------------------
'
With Selection
If .Count = 1 And Application.CutCopyMode = False Then ' If only 1 cell has been changed by user and
' ' not Cut/Copy then ...
Exit Sub ' allow the change & Exit the Sub
ElseIf .Count = 1 And Application.CutCopyMode = xlCopy Then ' ElseIf only 1 cell has been changed by user and
' ' Copy then ...
With Application
.EnableEvents = False ' Turn Events off to prevent potential code loop
.Undo ' Undo the change that was made by the user
'
Target.PasteSpecial Paste:=xlPasteValues ' Do the Copy/paste as pastespecial PasteValues
.CutCopyMode = False ' Clear the clipboard & 'Marching Ants'
.EnableEvents = True ' Turn Events back on
Exit Sub ' Exit the sub
End With
End If
'
'-----------------------------------------------------------------------------------------------
'
If .Count > 1 Then ' If more than one cell is being changed then
With Application
On Error Resume Next ' If error occurs, ignore it & exit sub
If .CommandBars("Standard").Controls("&Undo").List(1) = "Clear" Then Exit Sub ' Allow multiple deletetions via the delete key
On Error GoTo 0 ' Return error handling back to Excel
'
If .CommandBars("Standard").Controls("&Undo").List(1) = "Paste" Or _
.CommandBars("Standard").Controls("&Undo").List(1) = "Paste Special" And _
.CutCopyMode = xlCopy Then ' If Copy/paste detected then ...
'
.EnableEvents = False ' Turn Events off to prevent potential code loop
'
LastMergedColumn = Split(Selection.Address, "$")(3) ' Get LastMergedColumn letter
'
.Undo ' Undo the change that was made by the user
'
If ActiveCell.MergeCells Then ' If ActiveCell is merged then ...
'
' Copy/Paste to Merged cell range
'
EndAddressRow = Split(Selection.Address, "$")(4) ' Get the ending address row number
'
ActiveColumnLetter = Split(Cells(1, ActiveCell.Column).Address, "$")(1) ' Get ActiveColumnLetter
'
With Range(ActiveColumnLetter & Target.Row & ":" & _
ActiveColumnLetter & EndAddressRow)
If .MergeCells Then .UnMerge ' Unmerge the range
End With
'
Range(PreviousRangeSelected).Copy ' Copy the initial selected range
Range(ActiveColumnLetter & Target.Row & ":" & ActiveColumnLetter & _
EndAddressRow).PasteSpecial Paste:=xlPasteValues ' Paste as pastespecial PasteValues
'
For MergeCellCounter = Target.Row To EndAddressRow ' Loop through the rows of the target
Range(ActiveColumnLetter & MergeCellCounter & ":" & _
LastMergedColumn & MergeCellCounter).Merge ' Merge the Row columns
Next ' Loop back
'
.EnableEvents = True ' Turn Events back on
Exit Sub ' Exit Sub
Else ' Else ...
'
' Copy/Paste to UnMerged cell range
'
Target.PasteSpecial Paste:=xlPasteValues ' Do the Copy/paste as pastespecial PasteValues
.CutCopyMode = False ' Clear the clipboard & 'Marching Ants'
.EnableEvents = True ' Turn Events back on
Exit Sub ' Exit Sub
End If
End If
'
'-----------------------------------------------------------------------------------------------
'
If ActiveCell.MergeCells And .CommandBars("Standard").Controls("&Undo").List(1) _
<> "Auto Fill" And .CommandBars("Standard").Controls("&Undo").List(1) _
<> "Paste" Then ' If Merged cell found & we are not dragging
' ' or copying a cell then ...
' Standard write to single merged cell
'
EndAddressRow = ActiveCell.Row ' Save EndAddressRow
'
If EndAddressRow - Target.Row = 1 Then Exit Sub ' Allow a single Merged cell change
'
ElseIf ActiveCell.MergeCells And .CommandBars("Standard").Controls("&Undo").List(1) _
= "Auto Fill" Or ActiveCell.MergeCells And _
.CommandBars("Standard").Controls("&Undo").List(1) = "Paste" Then ' Else if Dragging or pasting to merged cell then ...
'
' Dragging Merged Cell or pasting to merged cell
'
.EnableEvents = False ' Turn Events off to prevent potential code loop
'
SelectionAddressArray = Split(Selection.Address(0, 0), ":") ' Separate Address Range into
' ' SelectionAddressArray
.Undo ' Undo the change that was made by the user
'
Range(SelectionAddressArray(0) & ":" & _
SelectionAddressArray(1)).FormulaR1C1 = Selection.Cells(1) ' Make the user changes without affecting format
.EnableEvents = True ' Turn Events back on
Exit Sub ' Exit the sub
End If
'
'-----------------------------------------------------------------------------------------------
'
SelectionRow = Selection.Row ' Save the Selection.Row into SelectionRow...24
'
EndDragColumnLetter = Split(Selection.Address, "$")(3) ' Get EndDragColumnLetter
StartDragColumnLetter = Split(Cells(1, ActiveCell.Column).Address, "$")(1) ' Get StartDragColumnLetter
'
.EnableEvents = False ' Turn Events off to prevent potential code loop
'
SelectionAddressArray = Split(Selection.Address(0, 0), ":") ' Separate Address Range into
' ' SelectionAddressArray
.Undo ' Undo the change that was made by the user
'
If SelectionRow = ActiveCell.Row Then ' If Dragging down then ...
Range(SelectionAddressArray(0) & ":" & EndDragColumnLetter & _
ActiveCell.Row).AutoFill Destination:=Range(SelectionAddressArray(0) & _
":" & SelectionAddressArray(1)), Type:=xlFillValues ' Make the user changes without affecting format
Else ' Else ...
Range(StartDragColumnLetter & ActiveCell.Row & ":" & EndDragColumnLetter & _
ActiveCell.Row).AutoFill Destination:=Range(SelectionAddressArray(1) & _
":" & SelectionAddressArray(0)), Type:=xlFillValues ' Make the user changes without affecting format
End If
'
.EnableEvents = True ' Turn Events back on
End With
End If
End With
End Sub
You are absolute number one 
).
so only do it if you feel great about it.. I will make a new post a with a more specific title and mention it's related to this thread.
