Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2579|回复: 6

[已解决]特殊复制粘贴

[复制链接]
发表于 2017-2-19 13:22 | 显示全部楼层 |阅读模式
本帖最后由 mate33 于 2017-2-19 23:12 编辑

特殊复制粘贴可否实现。
最佳答案
2017-2-19 20:18
本帖最后由 lygkkk 于 2017-2-19 20:37 编辑
  1. Private Sub 点击_Click()
  2.     Application.ScreenUpdating = False
  3.     Dim First_Position
  4.     Dim Last_Position
  5.     Dim Temp As String
  6.     Dim arr
  7.    
  8.      For Each Rng In Sheet1.Range("k14:bm30")
  9.         If Rng.Interior.Color = 65535 Or Rng.Interior.Color = 255 Then
  10.             Temp = Temp & "," & Rng.Address
  11.         End If
  12.     Next
  13.    
  14.     arr = Split(Temp, ",")
  15.     Temp = Selection.Address
  16.    
  17.     Sheet1.Range(arr(1), arr(UBound(arr) / 2)).Copy Sheet1.Range(Temp)
  18.     Sheet1.Range(arr(UBound(arr) / 2 + 1), arr(UBound(arr))).Copy
  19.     Sheet1.Range(Temp).PasteSpecial Paste:=xlPasteValues
  20.     Range(Temp).Select
  21.     Application.ScreenUpdating = True
  22. End Sub
复制代码

好了 应该没什么大问题了加了个按钮 如果没看见 往右拉

复制粘贴的VBA.rar

12.37 KB, 下载次数: 3

 楼主| 发表于 2017-2-19 18:07 | 显示全部楼层
回复

使用道具 举报

发表于 2017-2-19 18:39 | 显示全部楼层
试试看吧 不知道是不是你要的
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     If Target.Rows.Count = 1 Then
  3.         Application.ScreenUpdating = False
  4.         Dim First_Position
  5.         Dim Last_Position
  6.         Dim Temp As String
  7.         Dim arr
  8.         
  9.          For Each Rng In Sheet1.Range("k14:bm30")
  10.             If Rng.Interior.Color = 65535 Or Rng.Interior.Color = 255 Then
  11.                 Temp = Temp & "," & Rng.Address
  12.             End If
  13.         Next
  14.         
  15.         arr = Split(Temp, ",")
  16.         Temp = Target.Address
  17.         
  18.         Sheet1.Range(arr(1), arr(UBound(arr))).Copy Sheet1.Range(Temp)
  19.         Sheet1.Rows(Target.Row).ClearContents
  20.         Application.ScreenUpdating = True
  21.     End If
  22. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2017-2-19 19:04 | 显示全部楼层
lygkkk 发表于 2017-2-19 18:39
试试看吧 不知道是不是你要的

意思基本上是这样。但
1.2个粘贴的效果放在同一行里。粘贴的格式直接附在数值上,一行里即可。
2.不要自动的,要选取单元格后,再运行代码得到效果。
回复

使用道具 举报

发表于 2017-2-19 19:15 | 显示全部楼层
大爷 能不能给个样板 我们就不用猜灯谜了
回复

使用道具 举报

 楼主| 发表于 2017-2-19 19:37 | 显示全部楼层
lygkkk 发表于 2017-2-19 19:15
大爷 能不能给个样板 我们就不用猜灯谜了

这样的效果,麻烦看下。

复制粘贴的VBA.rar

12.75 KB, 下载次数: 3

回复

使用道具 举报

发表于 2017-2-19 20:18 | 显示全部楼层    本楼为最佳答案   
本帖最后由 lygkkk 于 2017-2-19 20:37 编辑
  1. Private Sub 点击_Click()
  2.     Application.ScreenUpdating = False
  3.     Dim First_Position
  4.     Dim Last_Position
  5.     Dim Temp As String
  6.     Dim arr
  7.    
  8.      For Each Rng In Sheet1.Range("k14:bm30")
  9.         If Rng.Interior.Color = 65535 Or Rng.Interior.Color = 255 Then
  10.             Temp = Temp & "," & Rng.Address
  11.         End If
  12.     Next
  13.    
  14.     arr = Split(Temp, ",")
  15.     Temp = Selection.Address
  16.    
  17.     Sheet1.Range(arr(1), arr(UBound(arr) / 2)).Copy Sheet1.Range(Temp)
  18.     Sheet1.Range(arr(UBound(arr) / 2 + 1), arr(UBound(arr))).Copy
  19.     Sheet1.Range(Temp).PasteSpecial Paste:=xlPasteValues
  20.     Range(Temp).Select
  21.     Application.ScreenUpdating = True
  22. End Sub
复制代码

好了 应该没什么大问题了加了个按钮 如果没看见 往右拉

复制粘贴的VBA.rar

24.15 KB, 下载次数: 75

回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 21:54 , Processed in 2.712133 second(s), 9 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表