复制单元格内容 - Excel 2010 VBA

Question

我试图完成一个相对（我认为）简单的任务。我想创建一个按钮，将活动单元格的内容复制到剪贴板。然后，我将使用crtl + v粘贴到另一个应用程序中。目标是复制excel表格内的一串文本......包括格式化和换行符。我想避免必须按F2，Crtl + shift + home，然后crtl + C。有没有办法做到这一点？

旧的Crtl + C和activecell.copy没有达到正确的结果，因为它们在粘贴到另一个应用程序时摆脱了任何换行符。 TIA

Answer 1

这个怎么样。这是一个字符的方式：

Sub CopyCellContents() 

'divides original cell into multiple, delimiter is line break (character 10) 
'copies the individual character text and formatting 
'copies result into clipboard 

Dim wsSrc As Worksheet 'sheet with original cells, the ones we want to copy from 
Dim wsTemp As Worksheet 'sheet with temporatily stored data, cells from here will be in clipboard 
Dim intOrigChars As Integer 'count of characters in original cell 
Dim intDestChars As Integer 'count of characters in destination cell (varies by rows) 

Set wsSrc = Worksheets("format") 'change to suit 
Set wsTemp = Worksheets("Temp") 'change to suit, create new sheet, just for purpose of temporarily storing contents of cell 

    With wsSrc 
     intDestChars = 1 
     'loop through all the characters in original cell; Change ".Cells(1, 1)" to suit you - use rename tool to change all of them below 
     For intOrigChars = 1 To .Cells(1, 1).Characters.Count 
      'if the character is a line break (character 10), move to next row and reset destination characters to 1 
      If Asc(.Cells(1, 1).Characters(intOrigChars, 1).Text) = 10 Then 
       rowAdd = rowAdd + 1 
       intDestChars = 1 
      Else 
       'copy text and formatting to temporary cells 
       With wsTemp.Cells(1 + rowAdd, 1).Characters(intDestChars, 1) 
        .Text = wsSrc.Cells(1, 1).Characters(intOrigChars, 1).Text 
        With .Font 
        .Bold = wsSrc.Cells(1, 1).Characters(intOrigChars, 1).Font.Bold 
        .Color = wsSrc.Cells(1, 1).Characters(intOrigChars, 1).Font.Color 
        .Italic = wsSrc.Cells(1, 1).Characters(intOrigChars, 1).Font.Italic 
        .Underline = wsSrc.Cells(1, 1).Characters(intOrigChars, 1).Font.Underline 
        .FontStyle = wsSrc.Cells(1, 1).Characters(intOrigChars, 1).Font.FontStyle 
        End With 
       End With 
       intDestChars = intDestChars + 1 
      End If 

     Next 
    End With 'wsSrc 

    'put result cells into clipboard 
    With wsTemp 
     .Range(.Cells(1, 1), .Cells(rowAdd + 1, 1)).Copy 
    End With 

End Sub 

Answer 2

使用本

Sub copy() 
    Dim clipboard As Object 
    Set clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") 
    clipboard.SetText ActiveCell.Value 
    clipboard.PutInClipboard 
End Sub