Copy Cell Contents - Excel 2010 VBA

Question

I am trying to accomplish a relatively (I think) simple task. I want to create a button that copies the contents of the active cell to the clipboard. I will then use crtl+v to paste into another application. The goal is to copy a string of text inside of an excel sheet... including formatting and line breaks. I want to avoid having to press F2, Crtl+shift+home, then crtl+C. Is there a way to do this?

Plain old Crtl+C and activecell.copy do not achieve the right result because they get rid of any line breaks when pasting into another app. TIA

Answer 1

use this

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

How about this. It's a character by character approach :

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