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

o0star0o

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

1. 
   
2. 
   
3. Public Sub 文本剪贴板()
   
4. 
   
5. '可单个和多个单元格选择复制
   
6. 
   
7.     Dim tt, a, i&, j&
   
8.     On Error GoTo xx 'Resume Next
   
9.     a = Selection '.Value
   
10.     For i = 1 To UBound(a)
    
11.         For j = 1 To UBound(a, 2)
    
12.             tt = tt & " " & a(i, j) '列之间用空格分隔
    
13.         Next
    
14.         tt = tt & vbNewLine '换行
    
15.     Next
    
16. GoTo xx1
    
17.     tt = Mid(tt, 2)
    
18. xx:
    
19. tt = Selection
    
20. xx1:
    
21.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") '数据放入剪贴板
    
22.             .SetText tt
    
23.             .PutInClipboard
    
24.    End With
    
25. End Sub
    

复制代码

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

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

liulang0808

1. 
   
2. 
   
3. Public Sub 文本剪贴板()
   
4. 
   
5. '可单个和多个单元格选择复制
   
6. 
   
7.     Dim tt, a, i&, j&
   
8.     On Error GoTo xx 'Resume Next
   
9.     Selection.SpecialCells(xlCellTypeVisible).Select
   
10.     If Selection.Cells.Count = 1 Then GoTo xx:
    
11.     Set rn = Selection.Cells(1)
    
12.     For Each Rng In Selection.Cells
    
13.         If Rng.Row <> rn.Row Then
    
14.             tt = tt & vbNewLine '换行
    
15.             tt = tt & " " & Rng.Value '列之间用空格分隔
    
16.             Set rn = Rng
    
17.         Else
    
18.             tt = tt & " " & Rng.Value '列之间用空格分隔
    
19.             Set rn = Rng
    
20.         End If
    
21.     Next Rng
    
22. 
    
23. GoTo xx1
    
24.     tt = Mid(tt, 2)
    
25. xx:
    
26. tt = Selection
    
27. xx1:
    
28.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") '数据放入剪贴板
    
29.             .SetText tt
    
30.             .PutInClipboard
    
31.    End With
    
32. End Sub
    

复制代码

o0star0o

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

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



点击调试，进去显示：

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

复制代码

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

o0star0o

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

等您回复~~~

liulang0808

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

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

o0star0o

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

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

liulang0808

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