在VBA中檢索複製單元格區域的位置

Question

我希望能夠複製單元格並粘貼唯一的數字格式。不幸的是，PasteSpecial命令沒有內置的選項。

有沒有辦法按下複製按鈕，選擇一些目標單元格，運行宏，並能夠以類似於VBA中的Selection對象的方式檢索複製的單元格，以便我可以使用它的屬性？

我能想到的唯一的選擇是粘貼到一個已知的空範圍（很遠），然後使用該中間範圍，如下圖所示：

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

謝謝！

Answer 1

在因特網上查找olelib.tlb（Edanmo的OLE接口&函數）。應該有很多下載鏈接。從VBA項目下載並參考（工具 - 參考資料）。

請注意，它不包含任何可執行代碼，只包含OLE函數和接口的聲明。

你也可能會注意到它很大，大約550kb。您只能從中提取所需的接口並重新編譯以獲得更輕的TLB文件，但這取決於您。 （如果你真的對TLB不滿意，還有一種黑暗的魔法路線，你根本不需要任何TLB，因爲你可以直接創建組件存根來直接調用vTable方法，但我不會感覺到。就像移植下面的代碼，這種方式）

然後創建一個輔助模塊，並把這段代碼到其中：

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 

然後在另一個模塊中創建可以綁定到工具欄按鈕或熱鍵實際宏：

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。

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 

足夠漫不經心......你明白了。