復制單元格內容-Excel 2010 VBA

Question

我正在嘗試完成一個相對（我認為）簡單的任務。 我想創建一個將活動單元格的內容復制到剪貼板的按鈕。 然后，我將使用crtl + v粘貼到另一個應用程序中。 目的是在Excel工作表內復制一串文本...包括格式和換行符。 我想避免必須按F2，Crtl + shift + home，然后再按crtl + C。 有沒有辦法做到這一點？

普通的舊Crtl + C和activecell.copy無法獲得正確的結果，因為它們粘貼到另一個應用程序時會消除任何換行符。 TIA

Answer 1

用這個

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

Answer 2

這個怎么樣。 這是一個接一個字符的方法：

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