Retrieve location of copied cell range in VBA - excel

Question

I'd like to be able to copy a cell and paste ONLY number formats. Unfortunately, there is no built-in option in the PasteSpecial command.
Is there a way to press the copy button, select some destination cells, run a macro, and be able to retrieve the copied cells in a way analogous to the Selection object in VBA so that I can use its properties?
The only alternative I can think of is pasting to a known empty range (very far away) and then using that intermediate range, as below:
Dim A As Range
Set A = Range("ZZ99999")
A.PasteSpecial Paste:=xlPasteAll
Selection.NumberFormat = A.NumberFormat
Thanks!

Answer 1

Find olelib.tlb on the Internet (Edanmo's OLE interfaces & functions). There should be plenty of download links. Download and reference from your VBA project (Tools - References).
Note that it does not contain any executable code, only declarations of OLE functions and interfaces.
Also you might notice it's quite big, about 550kb. You can extract only the needed interfaces from it and recompile to get a much lighter TLB file, but that is up to you.
(If you are really unhappy with a TLB, there is also the dark magic route where you don't need any TLBs at all because you create assembly stubs on the fly to call vTable methods directly, but I won't be feeling like porting the below code this way.)
Then create a helper module and put this code into it:
Option Explicit
' No point in #If VBA7 and PtrSafe, as the Edanmo's olelib is 32-bit
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Public Function GetCopiedRange() As Excel.Range
Dim CF_LINKSOURCE As Long
CF_LINKSOURCE = olelib.RegisterClipboardFormat("Link Source")
If CF_LINKSOURCE = 0 Then Err.Raise 5, , "Failed to obtain clipboard format CF_LINKSOURCE"
If OpenClipboard(0) = 0 Then Err.Raise 5, , "Failed to open clipboard."
On Error GoTo cleanup
Dim hGlobal As Long
hGlobal = GetClipboardData(CF_LINKSOURCE)
If hGlobal = 0 Then Err.Raise 5, , "Failed to get data from clipboard."
Dim pStream As olelib.IStream
Set pStream = olelib.CreateStreamOnHGlobal(hGlobal, 0)
Dim IID_Moniker As olelib.UUID
olelib.CLSIDFromString "{0000000f-0000-0000-C000-000000000046}", IID_Moniker
Dim pMoniker As olelib.IMoniker
olelib.OleLoadFromStream pStream, IID_Moniker, pMoniker
Set GetCopiedRange = RangeFromCompositeMoniker(pMoniker)
cleanup:
Set pMoniker = Nothing 'To make sure moniker releases before the stream
CloseClipboard
If Err.Number > 0 Then Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Function
Private Function RangeFromCompositeMoniker(ByVal pCompositeMoniker As olelib.IMoniker) As Excel.Range
Dim monikers() As olelib.IMoniker
monikers = SplitCompositeMoniker(pCompositeMoniker)
If UBound(monikers) - LBound(monikers) + 1 <> 2 Then Err.Raise 5, , "Invalid composite moniker."
Dim binding_context As olelib.IBindCtx
Set binding_context = olelib.CreateBindCtx(0)
Dim WorkbookUUID As olelib.UUID
olelib.CLSIDFromString "{000208DA-0000-0000-C000-000000000046}", WorkbookUUID
Dim wb As Excel.Workbook
monikers(LBound(monikers)).BindToObject binding_context, Nothing, WorkbookUUID, wb
Dim pDisplayName As Long
pDisplayName = monikers(LBound(monikers) + 1).GetDisplayName(binding_context, Nothing)
Dim raw_range_name As String ' Contains address in the form of "!SheetName!R1C1Local", need to convert to non-local
raw_range_name = olelib.SysAllocString(pDisplayName)
olelib.CoGetMalloc(1).Free pDisplayName
Dim split_range_name() As String
split_range_name = Split(raw_range_name, "!")
Dim worksheet_name As String, range_address As String
worksheet_name = split_range_name(LBound(split_range_name) + 1)
range_address = Application.ConvertFormula(ConvertR1C1LocalAddressToR1C1(split_range_name(LBound(split_range_name) + 2)), xlR1C1, xlA1)
Set RangeFromCompositeMoniker = wb.Worksheets(worksheet_name).Range(range_address)
End Function
Private Function SplitCompositeMoniker(ByVal pCompositeMoniker As olelib.IMoniker) As olelib.IMoniker()
Dim MonikerList As New Collection
Dim enumMoniker As olelib.IEnumMoniker
Set enumMoniker = pCompositeMoniker.Enum(True)
If enumMoniker Is Nothing Then Err.Raise 5, , "IMoniker is not composite"
Dim currentMoniker As olelib.IMoniker
Do While enumMoniker.Next(1, currentMoniker) = olelib.S_OK
MonikerList.Add currentMoniker
Loop
If MonikerList.Count > 0 Then
Dim res() As olelib.IMoniker
ReDim res(1 To MonikerList.Count)
Dim i As Long
For i = 1 To MonikerList.Count
Set res(i) = MonikerList(i)
Next
SplitCompositeMoniker = res
Else
Err.Raise 5, , "No monikers found in the composite moniker."
End If
End Function
Private Function ConvertR1C1LocalAddressToR1C1(ByVal R1C1LocalAddress As String) As String
' Being extra careful here and not doing simple Replace(Replace()),
' because e.g. non-localized row letter may be equal to localized column letter which will lead to double replace.
Dim row_letter_local As String, column_letter_local As String
row_letter_local = Application.International(xlUpperCaseRowLetter)
column_letter_local = Application.International(xlUpperCaseColumnLetter)
Dim row_letter_pos As Long, column_letter_pos As Long
row_letter_pos = InStr(1, R1C1LocalAddress, row_letter_local, vbTextCompare)
column_letter_pos = InStr(1, R1C1LocalAddress, column_letter_local, vbTextCompare)
If row_letter_pos = 0 Or column_letter_pos = 0 Or row_letter_pos >= column_letter_pos Then Err.Raise 5, , "Invalid R1C1Local address"
If Len(row_letter_local) = 1 And Len(column_letter_local) = 1 Then
Mid$(R1C1LocalAddress, row_letter_pos, 1) = "R"
Mid$(R1C1LocalAddress, column_letter_pos, 1) = "C"
ConvertR1C1LocalAddressToR1C1 = R1C1LocalAddress
Else
ConvertR1C1LocalAddressToR1C1 = "R" & Mid$(R1C1LocalAddress, row_letter_pos + Len(row_letter_local), column_letter_pos - (row_letter_pos + Len(row_letter_local))) & "C" & Mid$(R1C1LocalAddress, column_letter_pos + Len(column_letter_local))
End If
End Function
Credits go to Alexey Merson.

Answer 2

Here's one way. Obviously you'll have to change the range to suit your situation, but it should get you the general idea:
Dim foo As Variant
foo = Sheet1.Range("A1:A10").NumberFormat
Sheet1.Range("D1:D10").NumberFormat = foo
Which really can be simplified to:
Sheet1.Range("D1:D10").NumberFormat = Sheet1.Range("A1:A10").NumberFormat
and if all of your formats in the range are the same, you can just do:
Sheet1.Range("D1:D10").NumberFormat = Sheet1.Range("A1").NumberFormat
Enough rambling...you get the idea.