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

复制单元格内容 - Excel 2010 VBA

2 个答案: