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

zldccmx · 发表于 2009-7-15 18:26

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

我们完全可能通过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 · 发表于 2009-7-15 18:46

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

zldccmx · 发表于 2009-7-15 19:27

这是窗体代码！

   '撰写:老朽
   '网址: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 · 发表于 2009-7-15 19:31

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

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 · 发表于 2009-7-15 19:32

不连续区域复制粘贴.rar (14.92 KB, 下载次数: 210)
这是一个示例，供参考！

zldccmx · 发表于 2009-7-15 19:35

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

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

zldccmx · 发表于 2009-7-15 19:46

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

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

zldccmx · 发表于 2009-7-15 21:29

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

zldccmx · 发表于 2009-7-16 11:04

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

yuyangqh · 发表于 2010-4-8 00:32

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

		自动登录	找回密码
密码			免费注册

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

回复 1楼 zldccmx 的帖子