如何在从多维数组粘贴地址后进行可单击的单元格引用

Question

我有以下子程序，用于存储我在宏运行时所做的所有更改。

Public ChangeLog() As String

Sub Test()
Erase ChangeLog
'    Dim WS As Worksheet: Set WS = Sheets.Add(After:=Worksheets(Worksheets.Count))
'    WS.Name = "Change Log"
'    WS.Tab.Color = vbYellow
    Log ActiveSheet.Range("A2"), "Test1"
    Log ActiveSheet.Range("B2"), "Test2"
    Log ActiveSheet.Range("C2"), "Test3"
    'ActiveSheet.Range("B3") = ChangeLog
    ActiveSheet.Range("A1").Resize(UBound(ChangeLog, 2) + 1, 2) = WorksheetFunction.Transpose(ChangeLog)
End Sub

Function Log(Cell As Range, Reason As String) As String
    On Error Resume Next
    If (Not Not ChangeLog) = 0 Then
        ReDim ChangeLog(0 To 1, 0 To 1)
        ChangeLog(0, 0) = "Cells": ChangeLog(1, 0) = "Changes Made"
        ChangeLog(0, 1) = Cell.Address: ChangeLog(1, 1) = Reason
    Else
        ReDim Preserve ChangeLog(0 To 1, 0 To UBound(ChangeLog, 2) + 1)
        ChangeLog(0, UBound(ChangeLog, 2)) = Cell.Address: ChangeLog(1, UBound(ChangeLog, 2)) = Reason
    End If
    On Error GoTo 0
End Function

结果：

每次进行编辑时，我都需要向用户注意我将单元格地址和错误原因写入数组ChangeLog，我将其粘贴到我工作结束时活动表旁边的工作表中宏。出于测试目的，我已经排除了添加新电子表格的部分，这样我就可以确保我正确地处理多维数组（这是我的弱点）。这很好用，除了我想让单元格地址超链接/可点击，所以他们会把用户带到第一个电子表格上那个错误是/的位置（取决于我的宏清理或只是指向特定的错误）。

所以，我的问题是：

1. 如果将所有单元格引用从阵列粘贴到新电子表格中，我怎样才能使其可单击？什么是最快的方法？
2. 这是一种有效的方法还是有更简单的方法（而不是每次都调用该函数）？

Answer 1

Application.Goto方法是否适合您的任务而不需要超链接？您可以捕获Selection_Change事件（单击单元格时发生）。鉴于该单元格包含更改单元格的地址，您只能Goto该地址。

下面的示例代码为您提供了一个概念性的想法，但是，如果用户按键Selection_Change事件，则可能需要做更多的工作>他进入牢房的路。

你提到你对多维数组不太满意。鉴于我们只能重新编写最后一个维度，我不得不同意，当他们的目的是准备一个写入工作表的数组时，他们是一个真正的小提琴。这只是个人偏好，但如果我知道我将动态添加行（即增加第一维），那么我使用不同的数据存储方法（1D数组，Collection，Dictionary等。）并在写入之前将数据复制到2d输出数组。在下面的代码中，我使用了Collection作为示例。

在一个模块中：

Option Explicit
Private mChanges As Collection
Public Sub Test()
    Dim ws As Worksheet
    Dim output() As String
    Dim logItems As Variant
    Dim i As Long

    'Log some changes
    Set ws = ThisWorkbook.Worksheets("Sheet2")
    Set mChanges = New Collection
    LogChanges ws.Range("A1"), "Test1"
    LogChanges ws.Range("A2"), "Test2"
    LogChanges ws.Range("A3"), "Test3"

    'Populate the output array
    ReDim output(1 To mChanges.Count + 1, 1 To 2)
    output(1, 1) = "Cells": output(1, 2) = "Changes Made"
    i = 2
    For Each logItems In mChanges
        output(i, 1) = logItems(0)
        output(i, 2) = logItems(1)
        i = i + 1
    Next
    'Write output to sheet
    ws.Range("A1:B1").Resize(UBound(output, 1)).Value = output
    'Select cell "A1" so any cell click below "A1" can be captured
    ws.Activate: ws.Range("A1").Select

End Sub

Private Sub LogChanges(cell As Range, reason As String)
    Dim logItems(0 To 1) As String

    logItems(0) = cell.Address(False, False)
    logItems(1) = reason
    mChanges.Add logItems
End Sub

在您的工作表代码中：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim desired As Range
    Dim cell As Range

    If Target.Cells.Count = 1 Then
        Set desired = Me.Range("A2", Me.Cells(Me.Rows.Count, "A").End(xlUp))
        If Not Intersect(Target, desired) Is Nothing Then
            'Check whether the reason is a 'go to' one -> change string as req'd
            If Target.Offset(, 1).Value2 = "Test2" Then
                Set cell = Nothing
                On Error Resume Next
                'Define the cell address -> amend "Sheet1" to your user sheet name.
                Set cell = ThisWorkbook.Worksheets("Sheet1").Range(Target.Value2)
                On Error GoTo 0
                If Not cell Is Nothing Then
                    'Cell address is valid so go to it.
                    Application.Goto cell, True
                End If
            End If
        End If
    End If

End Sub

Answer 2

我能够通过使用Hyperlink公式并在我将值读入数组时创建公式来实现此目的。这样，当您将整个数组粘贴到某个范围时，公式/链接已经处于活动状态且可单击，这意味着您可以跳过必须遍历每个值并设置链接的步骤。

Public ChangeLog() As String

Sub Test()
    Erase ChangeLog
    Log ActiveSheet.Range("A2"), "Test1"
    Log ActiveSheet.Range("B2"), "Test2"
    Log ActiveSheet.Range("C2"), "Test3"
    Dim WS As Worksheet: Set WS = Sheets.Add(After:=Worksheets(1))
    WS.Name = "Change Log"
    WS.Tab.Color = vbYellow
    WS.Range("A1").Resize(UBound(ChangeLog, 2) + 1, 2) = WorksheetFunction.Transpose(ChangeLog)
End Sub

Function Log(Cell As Range, Reason As String) As String
    On Error Resume Next
    If (Not Not ChangeLog) = 0 Then
        ReDim ChangeLog(0 To 1, 0 To 1)
        ChangeLog(0, 0) = "Cells": ChangeLog(1, 0) = "Changes Made"
        ChangeLog(0, 1) = "=Hyperlink(" & """#'" & ActiveSheet.Name & "'!" & Cell.Address(False, False) & """,""" & Cell.Address(False, False) & """)"
        ChangeLog(1, 1) = "Hyperlink Test"
    Else
        ReDim Preserve ChangeLog(0 To 1, 0 To UBound(ChangeLog, 2) + 1)
        ChangeLog(0, UBound(ChangeLog, 2)) = "=Hyperlink(" & """#'" & ActiveSheet.Name & "'!" & Cell.Address(False, False) & """,""" & Cell.Address(False, False) & """)"
        ChangeLog(1, UBound(ChangeLog, 2)) = Reason
    End If
    On Error GoTo 0
End Function

预制超链接的结果：