在VBA中检索复制的单元格区域的位置
我想能够复制一个单元格并粘贴数字格式。 不幸的是，PasteSpecial命令没有内置的选项。
有没有办法按下复制button，select一些目标单元格，运行macros，并能够以类似于VBA中的Selection对象的方式检索复制的单元格，以便我可以使用它的属性？
我能想到的唯一select就是粘贴到已知的空白区域（非常远），然后使用该中间区域，如下所示：
Dim A As Range Set A = Range("ZZ99999") A.PasteSpecial Paste:=xlPasteAll Selection.NumberFormat = A.NumberFormat 谢谢！
在Internet上查找olelib.tlb （Edanmo的OLE接口和函数）。 应该有足够的下载链接。 从VBA项目下载并参考（工具 – 参考资料）。
请注意，它不包含任何可执行代码，只包含OLE函数和接口的声明。
你也许会注意到它很大，大约550kb。 您只能从中提取所需的接口并重新编译以获得更轻的TLB文件，但这取决于您。
（如果你真的对TLB感到不满意，那么还有一种你不需要任何TLB的黑暗魔法路由，因为你可以直接创build汇编存根来调用vTable方法，但是我不会感觉像移植下面的代码就是这样的。）
然后创build一个帮手模块，并把这个代码放进去：
Option Explicit 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 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(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
然后在另一个模块中创build一个实际的macros，你可以绑定到一个工具栏button或一个热键：
Public Sub MacroThatPastesNumberFormats() On Error GoTo oops If Application.CutCopyMode = False Then Err.Raise 5, , "Copy some source cells first." If Not TypeOf Application.Selection Is Range Then Err.Raise 5, , "To paste number formats, you need to select a cell first." Dim TargetCells As Range Set TargetCells = Selection If TargetCells.Areas.Count > 1 Then Err.Raise 5, , "Please select a single range." Dim SourceCells As Range Set SourceCells = GetCopiedRange() Dim r As Long, c As Long If TargetCells.Cells.Count = 1 Then 'Copy source range, target cell is the top left For r = 1 To SourceCells.Rows.Count For c = 1 To SourceCells.Columns.Count TargetCells.Offset(r - 1, c - 1).NumberFormat = SourceCells(r, c).NumberFormat Next Next Else 'Copy only within target range, wrapping around by columns if target range is wider than source range For r = 1 To TargetCells.Rows.Count For c = 1 To TargetCells.Columns.Count TargetCells(r, c).NumberFormat = SourceCells(r, ((c - 1) Mod SourceCells.Columns.Count) + 1).NumberFormat Next Next End If Exit Sub oops: MsgBox Err.Description, vbInformation Exit Sub End Sub
积分去Alexey Merson 。
这是一种方法。 显然，你必须改变范围以适应你的情况，但它应该让你的总体思路：
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
足够漫不经心…你明白了。