Question

我希望能够复制一个单元格并仅粘贴数字格式。不幸的是，PasteSpecial命令中没有内置选项。

有没有办法按下复制按钮，选择一些目标单元格，运行宏，并能够以类似于VBA中的Selection对象的方式检索复制的单元格，以便我可以使用它的属性？

我能想到的唯一选择是粘贴到已知的空范围（很远），然后使用该中间范围，如下所示：

Dim A As Range
Set A = Range("ZZ99999")
A.PasteSpecial Paste:=xlPasteAll
Selection.NumberFormat = A.NumberFormat

谢谢！

Answer 1

在Internet上查找olelib.tlb（Edanmo的OLE接口和功能）。应该有足够的下载链接。从VBA项目下载和参考（工具 - 参考）。

请注意，它不包含任何可执行代码，只包含OLE函数和接口的声明。

你也可能会注意到它很大，大约550kb。您只能从中提取所需的接口并重新编译以获得更轻的TLB文件，但这取决于您。
（如果你对TLB真的不满意，还有一条黑暗魔法路线你根本不需要任何TLB，因为你可以动态创建汇编存根直接调用vTable方法，但我不会感觉就像这样移植下面的代码。）

然后创建一个辅助模块并将此代码放入其中：

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

积分转到Alexey Merson。

Answer 2

这是一种方式。显然你必须改变范围以适应你的情况，但它应该让你有一个大概的想法：

Dim foo As Variant

foo = Sheet1.Range("A1:A10").NumberFormat

Sheet1.Range("D1:D10").NumberFormat = foo

真正可以简化为：

Sheet1.Range("D1:D10").NumberFormat = Sheet1.Range("A1:A10").NumberFormat

如果范围内的所有格式都相同，您可以这样做：

Sheet1.Range("D1:D10").NumberFormat = Sheet1.Range("A1").NumberFormat

足够漫无边际......你明白了。

在VBA中检索复制的单元格范围的位置

2 个答案: