【发布时间】：2017-09-03 17:01:36
【问题描述】：
我有以下代码，它跟踪活动单元格的先例并吐出一个带有信息的消息框。 （它还在其他工作表和工作簿中搜索先例）。
我是 VBA 新手，我想请求有关更改此代码的帮助，以便在活动工作表之后将前面的单元格、公式和地址吐出到新工作表中。请有人帮我理解如何做到这一点。
我应该创建一个新函数来创建一个新工作表并将动态信息复制到第一个 sub 中吗？
例如，如果我在 Sheet1 的单元格 C1 中有公式 A1 + B1，那么我想要在 Sheet2（新创建的工作表）中显示目标单元格为 C1，目标工作表为 Sheet1，源单元格为A1，源表为Sheet1。我还想要在 Sheet2 中显示目标单元格为C1，目标表为Sheet1，源单元格为B1，源表为Sheet1。
表 2：
代码：
Option Explicit
Public OtherWbRefs As Collection
Public ClosedWbRefs As Collection
Public SameWbOtherSheetRefs As Collection
Public SameWbSameSheetRefs As Collection
Public CountOfClosedWb As Long
Dim headerString As String
Sub RunMe()
Call FindCellPrecedents(ActiveCell)
End Sub
Sub FindCellPrecedents(homeCell As Range)
Dim i As Long, j As Long, pointer As Long
Dim maxReferences As Long
Dim outStr As String
Dim userInput As Long
If homeCell.HasFormula Then
Set OtherWbRefs = New Collection: CountOfClosedWb = 0
Set SameWbOtherSheetRefs = New Collection
Set SameWbSameSheetRefs = New Collection
Rem find closed precedents from formula String
Call FindClosedWbReferences(homeCell)
Rem find Open precedents from navigate arrows
homeCell.Parent.ClearArrows
homeCell.ShowPrecedents
headerString = "in re: the formula in " & homeCell.Address(, , , True)
maxReferences = Int(Len(homeCell.Formula) / 3) + 1
On Error GoTo LoopOut:
For j = 1 To maxReferences
homeCell.NavigateArrow True, 1, j
If ActiveCell.Address(, , , True) = homeCell.Address(, , , True) Then
Rem closedRef
Call CategorizeReference("<ClosedBook>", homeCell)
Else
Call CategorizeReference(ActiveCell, homeCell)
End If
Next j
LoopOut:
On Error GoTo 0
For j = 2 To maxReferences
homeCell.NavigateArrow True, j, 1
If ActiveCell.Address(, , , True) = homeCell.Address(, , , True) Then Exit For
Call CategorizeReference(ActiveCell, homeCell)
Next j
homeCell.Parent.ClearArrows
Rem integrate ClosedWbRefs (from parsing) With OtherWbRefs (from navigation)
If ClosedWbRefs.Count <> CountOfClosedWb Then
If ClosedWbRefs.Count = 0 Then
MsgBox homeCell.Address(, , , True) & " contains a formula with no precedents."
Exit Sub
Else
MsgBox "string-" & ClosedWbRefs.Count & ":nav " & CountOfClosedWb
MsgBox "Methods find different # of closed precedents."
End
End If
End If
pointer = 1
For j = 1 To OtherWbRefs.Count
If OtherWbRefs(j) Like "<*" Then
OtherWbRefs.Add Item:=ClosedWbRefs(pointer), key:="closed" & CStr(pointer), after:=j
pointer = pointer + 1
OtherWbRefs.Remove j
End If
Next j
Rem present findings
outStr = homeCell.Address(, , , True) & " contains a formula with:"
outStr = outStr & vbCrLf & vbCrLf & CountOfClosedWb & " precedents in closed workbooks."
outStr = outStr & vbCr & (OtherWbRefs.Count - CountOfClosedWb) & " precedents in other workbooks that are open."
outStr = outStr & vbCr & SameWbOtherSheetRefs.Count & " precedents on other sheets in the same workbook."
outStr = outStr & vbCr & SameWbSameSheetRefs.Count & " precedents on the same sheet."
outStr = outStr & vbCrLf & vbCrLf & "YES - See details about Other Books."
outStr = outStr & vbCr & "NO - See details about The Active Book."
Do
userInput = MsgBox(prompt:=outStr, Title:=headerString, Buttons:=vbYesNoCancel + vbDefaultButton3)
Select Case userInput
Case Is = vbYes
MsgBox prompt:=OtherWbDetail(), Title:=headerString, Buttons:=vbOKOnly
Case Is = vbNo
MsgBox prompt:=SameWbDetail(), Title:=headerString, Buttons:=vbOKOnly
End Select
Loop Until userInput = vbCancel
Else
MsgBox homeCell.Address(, , , True) & vbCr & " does not contain a formula."
End If
End Sub
Sub CategorizeReference(Reference As Variant, Home As Range)
Rem assigns reference To the appropriate collection
If TypeName(Reference) = "String" Then
Rem String indicates reference To closed Wb
OtherWbRefs.Add Item:=Reference, key:=CStr(OtherWbRefs.Count)
CountOfClosedWb = CountOfClosedWb + 1
Else
If Home.Address(, , , True) = Reference.Address(, , , True) Then Exit Sub
If Home.Parent.Parent.Name = Reference.Parent.Parent.Name Then
Rem reference In same Wb
If Home.Parent.Name = Reference.Parent.Name Then
Rem sameWb sameSheet
SameWbSameSheetRefs.Add Item:=Reference.Address(, , , True), key:=CStr(SameWbSameSheetRefs.Count)
Else
Rem sameWb Other sheet
SameWbOtherSheetRefs.Add Item:=Reference.Address(, , , True), key:=CStr(SameWbOtherSheetRefs.Count)
End If
Else
Rem reference To other Open Wb
OtherWbRefs.Add Item:=Reference.Address(, , , True), key:=CStr(OtherWbRefs.Count)
End If
End If
End Sub
Sub FindClosedWbReferences(inRange As Range)
Rem fills the collection With closed precedents parsed from the formula String
Dim testString As String, returnStr As String, remnantStr As String
testString = inRange.Formula
Set ClosedWbRefs = New Collection
Do
returnStr = NextClosedWbRefStr(testString, remnantStr)
ClosedWbRefs.Add Item:=returnStr, key:=CStr(ClosedWbRefs.Count)
testString = remnantStr
Loop Until returnStr = vbNullString
ClosedWbRefs.Remove ClosedWbRefs.Count
End Sub
Function NextClosedWbRefStr(FormulaString As String, Optional ByRef Remnant As String) As String
Dim workStr As String
Dim start As Long, interval As Long, del As Long
For start = 1 To Len(FormulaString)
For interval = 2 To Len(FormulaString) - start + 1
workStr = Mid(FormulaString, start, interval)
If workStr Like Chr(39) & "[!!]*'![$A-Z]*#" Then
If workStr Like Chr(39) & "[!!]*'!*[$1-9A-Z]#" Then
interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "#")
interval = interval - 3 * CLng(Mid(FormulaString, start + interval, 1) = ":")
interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]")
interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]")
interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]")
interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]")
NextClosedWbRefStr = Mid(FormulaString, start, interval)
Remnant = Mid(FormulaString, start + interval)
Exit Function
End If
End If
Next interval
Next start
End Function
Function OtherWbDetail() As String
Rem display routine
OtherWbDetail = OtherWbDetail & "There are " & OtherWbRefs.Count & " references to other workbooks. "
OtherWbDetail = OtherWbDetail & IIf(CBool(CountOfClosedWb), CountOfClosedWb & " are closed.", vbNullString)
OtherWbDetail = OtherWbDetail & vbCr & "They appear in the formula in this order:" & vbCrLf & vbCrLf
OtherWbDetail = OtherWbDetail & rrayStr(OtherWbRefs, vbCr)
End Function
Function SameWbDetail() As String
Rem display routine
SameWbDetail = SameWbDetail & "There are " & SameWbOtherSheetRefs.Count & " ref.s to other sheets in the same book."
SameWbDetail = SameWbDetail & vbCr & "They appear in this order, including duplications:" & vbCrLf & vbCrLf
SameWbDetail = SameWbDetail & rrayStr(SameWbOtherSheetRefs, vbCr)
SameWbDetail = SameWbDetail & vbCrLf & vbCrLf & "There are " & SameWbSameSheetRefs.Count & " precedents on the same sheet."
SameWbDetail = SameWbDetail & vbCr & "They are (out of order, duplicates not noted):" & vbCrLf & vbCrLf
SameWbDetail = SameWbDetail & rrayStr(SameWbSameSheetRefs, vbCr)
End Function
Function rrayStr(ByVal inputRRay As Variant, Optional Delimiter As String)
Rem display routine
Dim xVal As Variant
If IsEmpty(inputRRay) Then Exit Function
If Delimiter = vbNullString Then Delimiter = " "
For Each xVal In inputRRay
rrayStr = rrayStr & Delimiter & xVal
Next xVal
rrayStr = Mid(rrayStr, Len(Delimiter) + 1)
End Function
【问题讨论】：
-
这就是为什么我说“我有以下代码”=p haha 尽量不重新发明轮子
-
这就是为什么我提出“甚至不需要弄清楚你的原始代码在做什么！”在我的回答中。从
MsgBox获取预先格式化的数据似乎更容易（也更有趣）:)