从multidimensional array粘贴地址后如何制作可单击的单元格引用

我有以下的子例程，我正在使用它来存储我在运行macros时所做的所有更改。

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 ，我将其粘贴到我的macros结尾处的Activesheet旁边的工作表中。 出于testing的目的，我已经排除了添加新电子表格的部分，所以我可以确保正确处理multidimensional array（这是我的弱点）。 这很好，除了我想使单元格地址超链接/可点击的，所以他们会把用户带到第一个电子表格的错误是/是的位置（取决于我的macros是否清理或只是指向特定错误）。

所以，我的问题是：

1. 如何将所有单元格引用粘贴到数组中的新电子表格时可点击？ 什么是最快的方法？
2. 这是一个有效的方法，还是有一个更简单的方法（而不是每次调用函数）？

Answer 1

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

下面的示例代码为您提供了一个框架思路，但是如果您不想处理Selection_Change事件（如果用户按键到单元格），则可能需要更多的工作。

你提到你对multidimensional array不太舒服。 考虑到我们只能重新定义最后一个维度，我不得不同意，当他们的目的是准备写入工作表的数组时，他们是一个真正的小提琴。 这只是一个个人喜好，但如果我知道我会dynamic地添加行（即增加第一维），然后我使用不同的数据存储方法（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公式来创build公式，并在创build公式时读取数组中的值。 这样，当你将整个数组粘贴到一个范围时，公式/链接已经是活动和可点击的，这意味着你可以跳过必须遍历每个值并设置链接的步骤。

 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 

预制超链接中的结果：