asked on

Paste special causes loss of cell data validation.

Paste special causes loss of cell data validation. Using Excel 2003 version. I need to protect data validation in cells that are having data is being pasted into. Below is the VBA code is paste special. Newbie so any suggestions is greatly appreciated.

'Written by Aaron Bush 08/06/2007
'Free for private Use, provided "As-Is" with no warranties express or implied.
'Please retain this notice.
Option Explicit
Option Private Module
Option Compare Binary
Private m_oPasteFile As Object
Private Const m_sFSO_c As String = "Scripting.FileSystemObject"
Private Const m_sPasteProcedure_c As String = "PasteSpecial"
Private Const m_sUbndoProcedure_c As String = "UndoPasteSpecial"
Private Const m_sCutWarningProcedure_c As String = "CutWarning"
Private m_oWS As Excel.Worksheet
'Microsoft Scripting Runtime Constants:
Private Const TristateTrue As Long = -1
Private Const ForReading As Long = 1
Private Const ForWriting As Long = 2
Private Const TemporaryFolder As Long = 2
'Error Handling Constants:
Private Const m_sTitle_c As String = "Error Number: "
Private Const m_lButtons_c As Long = vbExclamation + vbMsgBoxSetForeground + vbMsgBoxHelpButton
'Interface Control Constants:
Const m_sTag_c As String = "ForcePaste"
 
'#####################################################
' CHANGE THIS AS REQUIRED!
Const mc_str_Password As String = "Union2009"
'#####################################################
 
Public Sub ForcePasteSpecial()
    LockInterface
    Excel.Application.OnKey "^v", m_sPasteProcedure_c
    Excel.Application.OnKey "+{INSERT}", m_sPasteProcedure_c
    Excel.Application.OnKey "^x", m_sCutWarningProcedure_c
    ReplacePasteButtons
    CutButtonsEnable False
Exit_Proc:
    On Error Resume Next
    UnlockInterface
    Exit Sub
Err_Hnd:
    VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
    Resume Exit_Proc
End Sub
Public Sub ReleasePasteControl()
    On Error GoTo Err_Hnd
    LockInterface
    Excel.Application.OnKey "^v"
    Excel.Application.OnKey "+{INSERT}"
    Excel.Application.OnKey "^x"
    RestorePasteButtons
    CutButtonsEnable True
Exit_Proc:
    On Error Resume Next
    m_oPasteFile.Delete True
    UnlockInterface
    Exit Sub
Err_Hnd:
    VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
    Resume Exit_Proc
End Sub
Private Sub PasteSpecial()
    On Error GoTo Err_Hnd
    Dim bRunOnce As Boolean
    Dim oFSO As Object
    Dim oTS As Object
    Dim oCll As Excel.Range
    Dim oDataRng As Excel.Range
    Dim lLstRow As Long
    Dim sTmpPth As String
    Const lPasteError_c As Long = 1004
    Const lFNFError_c As Long = 53
    LockInterface
    If Excel.ActiveWorkbook Is Excel.ThisWorkbook Then
        Set m_oWS = Excel.ActiveSheet
        m_oWS.Unprotect Password:=mc_str_Password
        Set oFSO = VBA.CreateObject(m_sFSO_c)
        If m_oPasteFile Is Nothing Then
CreateFile:
            sTmpPth = oFSO.BuildPath(oFSO.GetSpecialFolder(TemporaryFolder), oFSO.GetTempName)
        Else
            sTmpPth = m_oPasteFile.ShortPath
        End If
        If oFSO.FileExists(sTmpPth) Then oFSO.DeleteFile sTmpPth, True
        oFSO.CreateTextFile sTmpPth, True, True
        Set m_oPasteFile = oFSO.GetFile(sTmpPth)
        Set oTS = m_oPasteFile.OpenAsTextStream(ForWriting, TristateTrue)
        Set oDataRng = m_oWS.UsedRange
        lLstRow = oDataRng.Row
        oTS.WriteLine oDataRng.Address
        For Each oCll In oDataRng.Cells
            If lLstRow <> oCll.Row Then
                lLstRow = oCll.Row
                oTS.Write vbNewLine
            End If
            oTS.Write oCll.Formula & vbTab
        Next oCll
 
' UNPROTECT CODE
        Excel.Selection.PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, True, False
' REPROTECT CODE
        m_oWS.Protect Password:=mc_str_Password
    End If
Exit_Proc:
    On Error Resume Next
    oTS.Close
    UnlockInterface
    Exit Sub
Err_Hnd:
    Select Case VBA.Err.Number
        Case lPasteError_c
            If Not bRunOnce Then
                bRunOnce = True
                VBA.Err.Clear
                If Excel.Application.Dialogs(xlDialogPasteSpecial).Show Then
                    Resume Next
                Else
                    Resume Exit_Proc
                End If
            End If
        Case lFNFError_c
            Resume CreateFile
    End Select
    VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
    Resume Exit_Proc
    Resume
End Sub
 
Private Sub UndoPasteSpecial()
    On Error GoTo Err_Hnd
    Dim oTS As Object
    Dim lRow As Long
    Dim lCol As Long
    Dim vLine As Variant
    Dim sAddress As String
    Dim lColOffset As Long
    Const lLimit_c As Long = 256
    Const lStep_c As Long = 1
    Const lZero_c As Long = 0
    Const lOffset_c As Long = 1
    LockInterface
    If m_oPasteFile Is Nothing Then
        VBA.Err.Raise vbObjectError, m_sUbndoProcedure_c, "Cannot find stored paste data. Procedure cannot be reveresed."
    End If
    Set oTS = m_oPasteFile.OpenAsTextStream(ForReading, TristateTrue)
    If Not oTS.AtEndOfStream Then
        sAddress = oTS.ReadLine
        With m_oWS.Range(sAddress)
            lColOffset = .Column
            lRow = .Row
        End With
    End If
    m_oWS.UsedRange.ClearContents
    Do Until oTS.AtEndOfStream
        vLine = VBA.Split(oTS.ReadLine, vbTab, lLimit_c, vbBinaryCompare)
        For lCol = lZero_c To UBound(vLine)
            If VBA.IsNumeric(vLine(lCol)) Then
                m_oWS.Cells(lRow, lCol + lColOffset).Formula = CDbl(vLine(lCol))
            Else
                m_oWS.Cells(lRow, lCol + lColOffset).Formula = vLine(lCol)
            End If
        Next
        lRow = lRow + lStep_c
    Loop
Exit_Proc:
    On Error Resume Next
    oTS.Close
    UnlockInterface
    Exit Sub
Err_Hnd:
    VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
    Resume Exit_Proc
    Resume
End Sub
Private Sub ReplacePasteButtons()
    On Error GoTo Err_Hnd
    Dim oPasteBtns As Office.CommandBarControls
    Dim oPasteBtn As Office.CommandBarButton
    Dim oNewBtn As Office.CommandBarButton
    Const lIDPaste_c As Long = 22
    RestorePasteButtons
    Set oPasteBtns = Excel.Application.CommandBars.FindControls(ID:=lIDPaste_c)
    For Each oPasteBtn In oPasteBtns
        Set oNewBtn = oPasteBtn.Parent.Controls.Add(msoControlButton, Before:=oPasteBtn.Index, Temporary:=True)
        oNewBtn.FaceId = lIDPaste_c
        oNewBtn.Caption = oPasteBtn.Caption
        oNewBtn.TooltipText = oPasteBtn.TooltipText
        oNewBtn.Style = oPasteBtn.Style
        oNewBtn.BeginGroup = oPasteBtn.BeginGroup
        oNewBtn.Tag = m_sTag_c
        oNewBtn.OnAction = m_sPasteProcedure_c
        oPasteBtn.Visible = False
    Next
    Exit Sub
Err_Hnd:
    VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
End Sub
Private Sub RestorePasteButtons()
    On Error GoTo Err_Hnd
    Dim oBtns As Office.CommandBarControls
    Dim oBtn As Office.CommandBarButton
    Const lIDPaste_c As Long = 22
    Const m_sTag_c As String = "ForcePaste"
    Set oBtns = Excel.Application.CommandBars.FindControls(ID:=lIDPaste_c)
    For Each oBtn In oBtns
        oBtn.Visible = True
    Next
    Set oBtns = Excel.Application.CommandBars.FindControls(Tag:=m_sTag_c)
    If Not oBtns Is Nothing Then
        For Each oBtn In oBtns
            oBtn.Delete
        Next
    End If
    Exit Sub
Err_Hnd:
    VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
End Sub
Private Sub CutButtonsEnable(EnableButton As Boolean)
    On Error GoTo Err_Hnd
    Dim oCutBtns As Office.CommandBarControls
    Dim oCutBtn As Office.CommandBarButton
    Const lIDCut_c As Long = 21
    Set oCutBtns = Excel.Application.CommandBars.FindControls(ID:=lIDCut_c)
    For Each oCutBtn In oCutBtns
        oCutBtn.Enabled = EnableButton
    Next
    Exit Sub
Err_Hnd:
    VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
End Sub
Private Sub CutWarning()
On Error Resume Next
    VBA.MsgBox "The clipboard action ""Cut"" is not available for this workbook.", vbInformation + vbMsgBoxSetForeground, "Cut Disabled"
End Sub
Private Sub LockInterface()
    With Excel.Application
        .EnableEvents = False
        .ScreenUpdating = False
        .Cursor = xlWait
        .EnableCancelKey = xlErrorHandler
    End With
End Sub
Private Sub UnlockInterface()
    With Excel.Application
        .EnableEvents = True
        .ScreenUpdating = True
        .Cursor = xlDefault
        .EnableCancelKey = xlInterrupt
    End With
End Sub
THIS WORKBOOK
Option Explicit
Private Sub Workbook_Activate()
    Debug.Print "Workbook_Activate"
    ForcePasteSpecial
End Sub
 
'Private Sub Workbook_BeforeClose(Cancel As Boolean)
'    Debug.Print "Workbook_BeforeClose"
'    ReleasePasteControl
'End Sub
'
Private Sub Workbook_Deactivate()
    Debug.Print "Workbook_Deactivate"
    ReleasePasteControl
End Sub

Open in new window

SOLUTION