对Worksheet_SelectionChange事件写入代码后影响Excel剪切、复制粘贴的修正

    

        当在Excel的WorkSheet的SelectionChange事件中写入代码后有可能会影响到Excel的复制、剪切和粘贴功能。有可能会使此功能无效。最近在网上看到一段代码很有帮助，可以解决此问题，对代码进行了一些修改和注释。放到这里大家共享。
Worksheet中的代码：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim rngCutCopy As Range
    Dim iCutCopymode As Integer
    If Application.CutCopyMode Then
        Set rngCutCopy = CutCopyRange
    Else
        Set rngCutCopy = Nothing
    End If
    iCutCopymode = Application.CutCopyMode
    Target.Interior.ColorIndex = 34 '//这里写入你原来要写的代码
    If iCutCopymode = xlCopy Then
        rngCutCopy.Copy
    ElseIf iCutCopymode = xlCut Then
        rngCutCopy.Cut
    End If
End Sub
模块中的代码：

Option Explicit
'/锁定内存中指定的内存块,并返回一个地址值,令其指向内存块的起始处
Private Declare Function GlobalLock _
    Lib "kernel32" ( _
        ByVal hMem As Long) _
As Long
'/解锁先前被锁定的内存,使得指向内存块的指针无效
Private Declare Function GlobalUnlock _
    Lib "kernel32" ( _
        ByVal hMem As Long) _
As Long
'/得到的是内存块的大小
Private Declare Function GlobalSize _
    Lib "kernel32" ( _
        ByVal hMem As Long) _
As Long
'/打开剪切板
Private Declare Function OpenClipboard _
    Lib "user32" ( _
        ByVal hwnd As Long) _
As Long
'/关闭剪切板
Private Declare Function CloseClipboard _
    Lib "user32" () _
As Long
'/获取剪切板数据
Private Declare Function GetClipboardData _
    Lib "user32" ( _
        ByVal wFormat As Long) _
As Long
'/将一块内存的数据从一个位置复制到另一个位置
Private Declare Sub CopyMemory _
    Lib "kernel32" _
    Alias "RtlMoveMemory" ( _
        Destination As Any, _
        Source As Any, _
        ByVal Length As Long)
'//--------------------------------------------------------------------------------------//
'//-----用于取得处于复制或者剪切状态的单元格区域的函数-----------------//
'//--------------------------------------------------------------------------------------//
Public Function CutCopyRange() As Range
    On Error GoTo Hanlder
    Dim bytData() As Byte, hMem As Long, nClipsize As Long, lpData As Long
    Dim sSource As String, sTemp() As String
    Dim sWorkbook As String, sSheet As String, sRange As String
    '/打开剪切板
    OpenClipboard 0&
    '/取得剪切板中有关Excel单元格复制的信息数据
    hMem = GetClipboardData(49154)
    '/假如存在数据
    If CBool(hMem) Then
        '/取得数据内存的大小
        nClipsize = GlobalSize(hMem)
        '/锁定此内存块，并返回内存块的起始地址
        lpData = GlobalLock(hMem)
        If lpData <> 0 Then
            '/从新定义数组大小
            ReDim bytData(0 To nClipsize - 1) As Byte
            '/将内存复制到数组中
            CopyMemory bytData(0), ByVal lpData, nClipsize
            '/将二进制数组转换成字符串
            sSource = StrConv(bytData, vbUnicode)
            '/拆分字符串
            sTemp = Split(sSource, Chr(0))
            '/假使在拆分得到的字符串2中找到"/"（即工作薄已经保存）
            If InStr(sTemp(1), "/") Then
                '/取得工作薄的名称
                sWorkbook = Mid(sTemp(1), InStrRev(sTemp(1), "/") + 1)
            Else
                '/取得工作薄的名称
                sWorkbook = sTemp(1)
            End If
            '/取得工作表的名称
            sSheet = Left(sTemp(2), InStr(sTemp(2), "!") - 1)
            '/取得单元格区域的地址
            sRange = R1C1_To_A1(Mid(sTemp(2), InStr(sTemp(2), "!") + 1))
            '/取得处于剪切或者复制状态的单元格
            Set CutCopyRange = Workbooks(sWorkbook).Sheets(sSheet).Range(sRange)
        End If
        '/解锁 内存
        GlobalUnlock hMem
        
    '/假如未处于复制或者剪切状态
    Else
        Set CutCopyRange = Nothing
    End If
    '/关闭剪切板
    CloseClipboard
    Exit Function
Hanlder:
    Debug.Print Err.Number & Err.Description
End Function
'//--------------------------------------------------------------------------
'//----用于将单元格的R1C1引用样式转换为A1样式------------------
'//--------------------------------------------------------------------------
Private Function R1C1_To_A1(RgStr As String) As String
    Dim sTemp() As String
    If InStr(RgStr, ":") Then
        sTemp = Split(RgStr, ":")
        R1C1_To_A1 = R1C1_To_A1(sTemp(0)) & ":" & R1C1_To_A1(sTemp(1))
    Else
        RgStr = Mid(RgStr, 2)
        sTemp = Split(RgStr, "C")
        R1C1_To_A1 = Chr(64 + sTemp(1)) & sTemp(0)
    End If
End Function

详见附件：
点击下载