请问复制多行可见单元格的文本剪贴板

o0star0o · 发表于 2018-9-19 22:57

之前复制表格内容以为文本格式，用的这个宏：

Public Sub 文本剪贴板()
'可单个和多个单元格选择复制
Dim tt, a, i&, j&
On Error GoTo xx 'Resume Next
a = Selection '.Value
For i = 1 To UBound(a)
For j = 1 To UBound(a, 2)
tt = tt & " " & a(i, j) '列之间用空格分隔
Next
tt = tt & vbNewLine '换行
Next
GoTo xx1
tt = Mid(tt, 2)
xx:
tt = Selection
xx1:
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") '数据放入剪贴板
.SetText tt
.PutInClipboard
End With
End Sub

复制代码

但筛选后，点击复制会把其他隐藏部分的行也复制出来，想要只复制选中的“可见单元格”为文本模式
选中的可见单元格在表格中是按快捷键Alt+；，宏代码是：Selection.SpecialCells(xlCellTypeVisible).Select

求大神帮忙给下代码，怎么可以只复制选中的可见单元格为文本模式

liulang0808 · 发表于 2018-9-20 08:05

Public Sub 文本剪贴板()
'可单个和多个单元格选择复制
Dim tt, a, i&, j&
On Error GoTo xx 'Resume Next
Selection.SpecialCells(xlCellTypeVisible).Select
If Selection.Cells.Count = 1 Then GoTo xx:
Set rn = Selection.Cells(1)
For Each Rng In Selection.Cells
If Rng.Row <> rn.Row Then
tt = tt & vbNewLine '换行
tt = tt & " " & Rng.Value '列之间用空格分隔
Set rn = Rng
Else
tt = tt & " " & Rng.Value '列之间用空格分隔
Set rn = Rng
End If
Next Rng
GoTo xx1
tt = Mid(tt, 2)
xx:
tt = Selection
xx1:
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") '数据放入剪贴板
.SetText tt
.PutInClipboard
End With
End Sub

复制代码

o0star0o · 发表于 2018-9-24 22:40

liulang0808 发表于 2018-9-20 08:05

谢谢回复，测试可以复制筛选出来的可见单元格，但是有个BUG，只能复制2个及以上的，不能只选中1个单元格就复制一个到文本剪贴板，显示溢出了，您看下提示：

T2YS(`VAFXBM_IAD`9S0YEB.png

点击调试，进去显示：
$PW[EDHY_`{8AXFJITG)G.png$

'聚光灯
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Cells.Interior.ColorIndex = xlNone: Exit Sub
Cells.Interior.ColorIndex = xlNone
Target.EntireRow.Interior.ColorIndex = 37
End Sub

复制代码

这是聚光灯的代码，您看怎么帮我优化下呢，处理好了这个我加您QQ，谢谢您经常回复我的帖子，下次有需求有偿找您

o0star0o · 发表于 2018-9-25 16:09

liulang0808 发表于 2018-9-20 08:05

等您回复~~~

liulang0808 · 发表于 2018-9-25 16:40

o0star0o 发表于 2018-9-25 16:09
等您回复~~~

楼主到底是要解决什么问题，上面代码的问题处理了吧，3楼是另外一个问题吗？

o0star0o · 发表于 2018-9-26 00:21

liulang0808 发表于 2018-9-25 16:40
楼主到底是要解决什么问题，上面代码的问题处理了吧，3楼是另外一个问题吗？

可以实现，但是我原代码是可以单个和多个单元格都可以进行复制，您的修改后的代码不能单个复制，希望您能帮我修改下

liulang0808 · 发表于 2018-10-4 20:14

o0star0o 发表于 2018-9-26 00:21
可以实现，但是我原代码是可以单个和多个单元格都可以进行复制，您的修改后的代码不能单个复制，希望您能 ...

Public Sub test()

'?????????????

Dim tt, a, i&, j&
On Error GoTo xx 'Resume Next
If Selection.Cells.Count = 1 Then GoTo xx:
Selection.SpecialCells(xlCellTypeVisible).Select

Set rn = Selection.Cells(1)
For Each Rng In Selection.Cells
      If Rng.Row <> rn.Row Then
         tt = tt & vbNewLine '??
         tt = tt & " " & Rng.Value '????????
         Set rn = Rng
      Else
         tt = tt & " " & Rng.Value '????????
         Set rn = Rng
      End If
Next Rng

GoTo xx1
tt = Mid(tt, 2)
xx:
tt = Selection.Value
xx1:
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") '???????
         .SetText tt
         .PutInClipboard
End With
End Sub

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

[求助] 请问复制多行可见单元格的文本剪贴板

评分