Excel VBA - 当活动/选定单元格不同时获取复制的单元格地址

Question

在 Excel 中使用 VBA 时，当活动/选定单元格不同时，有没有办法获取复制单元格的地址？单元格将在运行宏之前被复制。

例如，假设当前复制了单元格 R1，但所选单元格和视图（我在屏幕上看到的）位于 ZAA 列的某个位置。举个简单的例子，我想基本上放大到复制单元格所在的区域，而不必手动滚动查找它。

Answer 1

首先我只想说，所有解决方案都非常老套。

我认为最有效的“hacky”方法可能有很多边缘情况，但我会抓住CTRL+C 和CTRL+X（剪切和复制快捷方式）并用它们做事。

这不适用于上下文菜单剪切和复制方法 - 有一些方法可以尝试获取这些方法，但它们有问题（主要是如果你复制一个东西然后复制另一个东西而不重置 CutCopyMode 的错误）我不确定是否有办法在旧的当前处于活动状态时检测“新”剪切/复制（您当然不能通过检查Application.CutCopyMode 来做到这一点）。

此方法的另一个（可能？）好处是它实际上遵循您粘贴时剪切的范围......所以如果您再次跳转，您将看到它被移动到的位置（请注意，如果剪切和粘贴到新工作表，这不起作用）。

在工作簿对象中：

Private Sub Workbook_Open()
Application.OnKey "^c", "CopyFired"
Application.OnKey "^x", "CutFired"
End Sub

在一个模块中：

Dim CutCopyRange As Range
Sub CopyFired()
Set CutCopyRange = Selection
Selection.Copy
End Sub

Sub CutFired()
Set CutCopyRange = Selection
Selection.Cut
End Sub

Sub JumpToRange()
'You can add CutCopyRange.Parent.Select if you switch worksheets
'But this will not follow a cut->paste from one sheet to another properly
'The Range seems to update itself, but not its parent.
If Not CutCopyRange Is Nothing Then CutCopyRange.Select
End Sub

如果Application.CutCopyMode 为假，您可能还想设置Worksheet_Change 捕获以清除CutCopyRange，但我不会搞砸这一切。如果他们使用CTRL+C 复制并使用CTRL+X 剪切，您应该能够通过简单地捕获印刷机来捕获它。

请注意，如果您尝试剪切/复制工作表上的对象，此代码也可能存在错误。

调用JumpToRange 跳转到当前范围 - 如果它在不同的工作表上，您可能需要先选择工作表 - 可能有一些与此相关的额外代码。

我认为您也可以使用ScrollTo 而不是Select，但我想这是经销商的选择。

Answer 2

这是我多年来一直用于执行此操作的代码的简化版本，我认为它运行可靠。无论复制是通过Ctrl+C 或Ctrl+Insert 还是通过右键单击上下文菜单或功能区完成的，它都会返回复制的范围（如果有的话）。

Public Function GetCopiedRange()
    Dim Cell1 As Range
    Dim Cell2 As Range
    Dim ConvexHull As Range
    Dim CopyOfErr As String
    Dim Format As Variant
    Dim Formats As Variant
    Dim Formula1 As String
    Dim Formula2 As String
    Dim SU As Boolean
    Dim tempBook As Excel.Workbook
    Dim TempRange As Range

    On Error GoTo ErrHandler

    If Application.CutCopyMode <> xlCopy Then
        Err.Raise vbObjectError + 1, , "#No copied Range found!"
        Exit Function
    End If
    'Examine ClipBoard formats to check that what's copied is indeed a range
    'Found this tip at http://www.ozgrid.com/forum/showthread.php?t=66773
    Formats = Application.ClipboardFormats
    For Each Format In Formats
        If Format = xlClipboardFormatCSV Then
            GoTo Continue
        End If
    Next
    Err.Raise vbObjectError + 1, , "#No copied Range found!"
    Exit Function
Continue:
    SU = Application.ScreenUpdating
    If SU Then Application.ScreenUpdating = False
    Set tempBook = Application.Workbooks.Add
    tempBook.Worksheets(1).Paste Link:=True
    Set TempRange = Selection

    With TempRange
        Formula1 = .Cells(1, 1).Formula
        Formula2 = .Cells(.Rows.Count, .Columns.Count).Formula
    End With

    'Rubberduck (2.4.1.4627) incorrectly flags these three lines as implicitly referencing the active sheet
    Set Cell1 = Range(Right$(Formula1, Len(Formula1) - 1))
    Set Cell2 = Range(Right$(Formula2, Len(Formula2) - 1))
    Set ConvexHull = Range(Cell1, Cell2)
    'https://en.wikipedia.org/wiki/Convex_hull

    If ConvexHull.Cells.CountLarge = TempRange.Cells.CountLarge Then
        ' Copied Range had one area only.
        Set GetCopiedRange = ConvexHull
    Else
        'There are now two possibilities:
        'a) Copied range had multiple areas, each of the same width and all aligned vertically; or
        'b) Copied range had multiple areas, each of the same height and all aligned horizontally.
        ' It is not possible to copy other layouts of multiple-area ranges (as of Office 2013)
        ' Coping with cases a) and b) is possible but complex, so just raise an error.
        Err.Raise vbObjectError + 1, , "Copied Range has multiple areas"
    End If
    tempBook.Close False
    If SU Then Application.ScreenUpdating = True

    Exit Function
ErrHandler:
    CopyOfErr = Err.Description
    If Not tempBook Is Nothing Then tempBook.Close False
    If SU Then Application.ScreenUpdating = True
    Err.Raise vbObjectError + 1, , CopyOfErr
End Function