求助！帮忙修改代码，多谢！！！具体要求详见附件。

zjdh

1. Private Sub CommandButton4_Click()    '按钮粘贴
   
2.     On Error GoTo Err
   
3.     Set D = New DataObject
   
4.     D.GetFromClipboard
   
5.     Y = UBound(Split(D.GetText(1), vbCrLf))
   
6.     X = UBound(Split(D.GetText(1), vbTab)) / Y
   
7.     X1 = Selection.Column
   
8.     Y1 = Selection.Row
   
9.     Z = UsedRange.Rows.Count
   
10.     If Y + Y1 > Z Then MsgBox "你粘贴的区域超过了表格区域": Exit Sub
    
11.     R = Array(7, 8, 10, 11, 12, 14, 15, 16, 18, 19, 20)
    
12.     For I = X1 To X + X1
    
13.         For J = 0 To UBound(R)
    
14.             If R(J) = I Then MsgBox "你选择的区域不得粘贴！": Exit Sub
    
15.         Next
    
16.     Next
    
17.     Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    
18.     Exit Sub
    
19. Err:
    
20.     If Application.CutCopyMode = False Then
    
21.         MsgBox "您还没复制，或请重新复制。"
    
22.     Else
    
23.         MsgBox "如果粘贴整行或整列，请注意粘贴位置；" & Chr(10) & "另外，本命令在剪切模式下不可使用。"
    
24.     End If
    
25. End Sub
    

复制代码

tsingcea

zjdh 发表于 2012-8-12 19:01

非常感谢！几乎完美！太感谢您啦。您的大恩大德我会铭记在心的。就是代码太专业了，我有不少都看不懂。不过，没关系，今后有的是时间学习。总之，还是太感谢您啦。

tsingcea

zjdh 发表于 2012-8-12 19:01

经测试，发现这组代码在“模块”中无法正常使用。不晓得是什么原因，只能在Sheet里面使用。如果方便的话，给咱讲解讲解好吗？总之，这也已经可以说是解决了一个很大的问题了。

zjdh

我是特意做成不可在模块中运行的，那是怕你其他工作表格式不一致，造成功能混乱！
若各工作表格式一致，可将语句：
Z =UsedRange.Rows.Count 改成
Z = ActiveSheet.UsedRange.Rows.Count
放在模块中即可以啦!
注意：
R = Array(7, 8, 10, 11, 12, 14, 15, 16, 18, 19, 20)
是规定不可粘贴的列序号，可以灵活变化！

tsingcea

zjdh 发表于 2012-8-13 08:32
我是特意做成不可在模块中运行的，那是怕你其他工作表格式不一致，造成功能混乱！
若各工作表格式一致，可 ...

非常感谢了。在实际操作中，还有一个小问题。
可是因为不同工作表中有稍微的不同。主要是列号不同。那么，可否指定比如Sheet1、Sheet3、Sheet4用一种，而Sheet2、Sheet5用另外一种呢？就是为模块指定工作表。
我知道可以把有些代码摆在工作表里，但是那样会比较麻烦。如果能够指定工作表，操作起来会方便很多。

zjdh

那就在对R数组赋值时作一个判断，再分别赋值。

tsingcea

zjdh 发表于 2012-8-16 08:07
那就在对R数组赋值时作一个判断，再分别赋值。

这个思路我有的，但是不知该如何去做这个判断。还望大师明示。只要给个例子就成，我可以自己套。

tsingcea

zjdh 发表于 2012-8-16 08:07 那就在对R数组赋值时作一个判断，再分别赋值。

连续工作表，比如Sheet1到Sheet4，有没有类似Range的写法？比如Range（"Sheet1"."Sheet4"），我的意思是总比一个一个注明方便。当然，因为Sheet的随机性强，一个一个判断注明的方法还是核心方法。

zjdh

把  R = Array(7, 8, 10, 11, 12, 14, 15, 16, 18, 19, 20)
替换成：
     NM = UCase(ActiveSheet.Name)
   '第一组
    SH1 = Array("SHEET1", "SHEET3", "SHEET5", "SHEET7")  '第一组工作表
    R1 = Array(7, 8, 10, 11, 12, 14, 15, 16, 18, 19, 20) '第一组不可粘贴列号
    For I = 0 To UBound(SH1)
        If SH1(I) = NM Then R = R1: Exit For
    Next
    '第二组
    SH2 = Array("SHEET2", "SHEET4", "SHEET6", "SHEET8")
    R2 = Array(1, 2, 3, 11, 12, 14, 15, 16, 18, 19, 20)
    For I = 0 To UBound(SH2)
        If SH2(I) = NM Then R = R2: Exit For
    Next
    '........其他组
    If I > UBound(SH2) Then Exit Sub

        注意：以上工作表名称一定要大写！

tsingcea

zjdh 发表于 2012-8-17 18:14
把  R = Array(7, 8, 10, 11, 12, 14, 15, 16, 18, 19, 20)
替换成：
     NM = UCase(ActiveSheet.Name) ...

之前说过最后一个问题了，如今却又几次增加提问，真是不好意思。可能我比较钻牛角尖吧，总是希望能够尽善尽美，做到理想状态。所以，还得麻烦老师了。真是不好意思啊。
测试发现如下问题：
1、替换模块中的程序后无法实现粘贴了。但是工作表的原来的数据（没有替换的数据）没有问题，依然可以粘贴。主要是为了有些新的功能，这个程序我在工作表中会用到，在模块中也会用到，只是模块中的需要区分下工作表。
2、如果Sheet2和Sheet4是一种，其他的工作表是另外一种，能否这样写，我是觉得这样的话应该会更方便新增工作表，因为2和4比较特殊，其他的都一样。
我替换之后的代码如下
On Error GoTo Err
    Set d = New DataObject
    d.GetFromClipboard
    Y = UBound(Split(d.GetText(1), vbCrLf))
    X = UBound(Split(d.GetText(1), vbTab)) / Y
    X1 = Selection.Column
    Y1 = Selection.Row
    Z = ActiveSheet.UsedRange.Rows.Count
    If Y + Y1 > Z Then MsgBox "你粘贴的区域超过了表格区域": Exit Sub
    NM = UCase(ActiveSheet.Name)
   '第一组
    SH1 = Array("SHEET1", "SHEET3", "SHEET5", "SHEET7")  '第一组工作表
    R1 = Array(7, 8, 10, 11, 12, 14, 15, 16, 18, 19, 20) '第一组不可粘贴列号
    For i = 0 To UBound(SH1)
        If SH1(i) = NM Then R = R1: Exit For
    Next
    '第二组
    SH2 = Array("SHEET2", "SHEET4", "SHEET6", "SHEET8")
    R2 = Array(10, 11, 12, 14, 15, 16, 18, 19, 20)
    For i = 0 To UBound(SH2)
        If SH2(i) = NM Then R = R2: Exit For
    Next
    '........其他组
    If R = "" Then Exit Sub
    For i = X1 To X + X1
        For j = 0 To UBound(R)
            If R(j) = i Then MsgBox "你选择的区域不得粘贴！": Exit Sub
        Next
    Next
    Selection.PasteSpecial Paste:=xlPasteValues
    Exit Sub
Err:
    If Application.CutCopyMode = False Then
        MsgBox "您还没复制，或请重新复制。"
    Else
        MsgBox "如果粘贴整行或整列，请注意粘贴位置；" & Chr(10) & "另外，本命令在剪切模式下不可使用。"
    End If