解决不连续区域无法复制、粘贴问题

zldccmx

在工作表中，系统不支持不连续区域复制、粘贴，这的确有点伤脑筋。有没有办法实现这个简单的功能呢？
答案是肯定的。

我们完全可能通过VBA来实现。

先来看一下一个简单的将不连续区域转换成值的功能。

本例假定有三个区域组成的一个不连续的区域，[a1:a12]、 [c3:C12]、 [e5:f6]，里面都是公式，现在希望将这三个区域的公式直接转换成值
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-7-14 下午 05:24:11
Sub zldccmx()
    Dim Rng As Range , Rn As Range
    Set Rng = Union([a1:a12], [c3:C12], [e5:f6]) '对于不连续区域，使用分块来完成
    For Each Rn In Rng.Areas
        Rn.Value = Rn.Value
    Next
End Sub

楼下将介绍不连续区域复制到另外一个不连续的区域中

yrgui

第五句“Rn.Value = Rn.Value”错了吧

zldccmx

这是窗体代码！

      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-7-15 下午 07:26:01
Private Sub CommandButton1_Click()
    Dim Rng As Range , Sh As Worksheet, V, Rn As Range
    On Error GoTo ex
    Dim Offset_Row%, Offset_Col%
    Set Rng = MyTarget(1, 1)
    V = Split(Me.RefEdit1.Text, "!")
    V(1) = Split(Split(V(1), ",")(0), ":")(0)
    Set Sh = Sheets(V(0))
    If Mysheet.Name = V(0) Then '判断是否是同一个工作表
        For Each Rn In MyTarget.Areas '将不连续区域合并为一个连续区域，以判断选定的目标单元格是否与不连续区域存在交叉
            Set Rng = Range (Rng, Rn)
        Next
        If Not Application.Intersect(Rng, Range (V(1))) Is Nothing Then
            If MsgBox("你所选择的区域有交叉，可能会导致数据错位！" & vbCrLf _
                    & vbLf & "是否继续？", vbYesNo + vbCritical, "请确认操作！") _
               <> vbYes Then Exit Sub
        End If
    End If
    With MyTarget
        .Areas(1).Copy Sh.Range(V(1))    '先复制首区域并粘贴到对应的区域
        '如果是选择性粘贴，则使用以下语句
        '.Areas(1).Copy: Sh.Range(V(1)).PasteSpecial xlPasteValues, , , False    '选择性粘贴，"值"，不转置
        For i = 2 To .Areas.Count
            Offset_Row = .Areas(i)(1, 1).Row - .Areas(1)(1, 1).Row    '计算各区域与首区域的行偏移
            Offset_Col = .Areas(i)(1, 1).Column - .Areas(1)(1, 1).Column    '计算各区域与首区域的列偏移
            .Areas(i).Copy Sh.Range(V(1)).Offset(Offset_Row, Offset_Col)    '复制之后粘贴到对应的区域
        Next
    End With
ex:     If Err.Number <> 0 Then MsgBox "错误号" & Err.Number & vbCrLf & vbLf _
                                     & Err.Description & vbCrLf & vbLf & "你选择的目标单元格地址有误" _
                                     & vbCrLf & "导致没有办法粘贴！": Err.Clear
End Sub

zldccmx

插入一模块，复制进以下代码

Option Explicit
Public MyTarget As Range , Mysheet As Worksheet




这是工作簿代码，复制进以下代码


Option Explicit

      '撰写:38度:老朽
      '网址:http://www.38duoffice.cn/bbs
      '日期:2009-7-15 下午 07:30:25
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object , ByVal Target As Range , Cancel As Boolean )
    If Target.Areas.Count > 1 Then
        Set MyTarget = Target
        Set Mysheet = Sh
        UserForm1.Show
        Cancel = True
    End If
End Sub

zldccmx

不连续区域复制粘贴.rar (14.92 KB, 下载次数: 210)

2009-7-15 19:32 上传

点击文件名下载附件
阅读权限: 20

这是一个示例，供参考！

zldccmx

原帖由 yrgui 于 2009-7-15 18:46 发表
第五句“Rn.Value = Rn.Value”错了吧

绝对放心，没有任何错误！

zldccmx

原帖由 yrgui 于 2009-7-15 18:46 发表
第五句“Rn.Value = Rn.Value”错了吧

绝对放心，没有任何错误！

zldccmx

选定不连续区域之后，按鼠标右键！弹出窗体
OK

zldccmx

上传一个GIF文件，希望能顶起来

yuyangqh

不错，顶一下，但这种用法，我还没有遇到过