问题
I've found a problem in Excel/VBA in the Worksheet_Change Event. I need to assign Target.Dependents to a Range, but if it has no dependents it brings up an error. I tried testing Target.Dependents.Cells.Count but that didn't work. Any Ideas?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 OR Target.Dependents.Cells.Count = 0 Then Exit Sub
Dim TestRange As Range
Set TestRange = Target.Dependents
I've also tried "Target.Dependents Is Nothing".
回答1:
Short answer, there is no way to test for dependents without raising an error, as the property itself is set to raise an error if accessed and there aren't any. I dislike the design but there is no way to prevent it without suppressing errors. AFAIK this is about the best you are going to be able to do with it.
Sub Example()
Dim rng As Excel.Range
Set rng = Excel.Selection
If HasDependents(rng) Then
MsgBox rng.Dependents.Count & " dependancies found."
Else
MsgBox "No dependancies found."
End If
End Sub
Public Function HasDependents(ByVal target As Excel.Range) As Boolean
On Error Resume Next
HasDependents = target.Dependents.Count
End Function
Explanation, if there are no dependents an error is raised and the value of HasDependents stays unchanged from the type default,which is false, thus false is returned. If there are dependents, the count value will never be zero. All non-zero integers convert to true, so when count is assigned as the return value, true is returned. It's pretty close to what you are already using.
回答2:
Here is the only way I found to make it work, but I'd love a better solution:
On Error Resume Next
Dim TestRange As Range
Set TestRange = Target.Dependents
If TestRange.HasFormula And Err.Number = 0 Then ...
回答3:
As found on: http://www.xtremevbtalk.com/t126236.html
'Returns a Collection of all Precedents or Dependents found in the Formula of the Cell argument
'Arguments : 'rngCell' = the Cell to evaluate
' : 'blnPrecedents' = 'TRUE' to list Precedents, 'FALSE' to list Dependents
'Dependencies : 'Get_LinksFromFormula' function
'Limitations : does not detect dependencies in other Workbooks
'Written : 08-Dec-2003 by member Timbo @ visualbasicforum.com
Function Get_LinksCell(rngCell As Range, blnPrecedents As Boolean) As Collection
Dim rngTemp As Range
Dim colLinksExt As Collection, colLinks As New Collection
Dim lngArrow As Long, lngLink As Long
Dim lngErrorArrow As Long
Dim strFormula As String, strAddress As String
Dim varLink
On Error GoTo ErrorH
'check parameters
Select Case False
Case rngCell.Cells.Count = 1: GoTo Finish
Case rngCell.HasFormula: GoTo Finish
End Select
Application.ScreenUpdating = False
With rngCell
.Parent.ClearArrows
If blnPrecedents Then
.ShowPrecedents
Else: .ShowDependents
End If
strFormula = .Formula
'return a collection object of Links to other Workbooks
If blnPrecedents Then _
Set colLinksExt = Get_LinksFromFormula(rngCell)
LoopArrows_Begin:
Do 'loop all Precedent/Dependent Arrows on the sheet
lngArrow = lngArrow + 1
lngLink = 1
Do
Set rngTemp = .NavigateArrow(blnPrecedents, lngArrow, lngLink)
If Not rngTemp Is Nothing Then
strAddress = rngTemp.Address(External:=True)
colLinks.Add strAddress, strAddress
End If
lngLink = lngLink + 1
Loop
Loop
LoopArrows_End:
If blnPrecedents Then
.ShowPrecedents True
Else: .ShowDependents True
End If
End With
If blnPrecedents Then 'add the external Link Precedents
For Each varLink In colLinksExt
colLinks.Add varLink, varLink
Next varLink
End If
Finish:
On Error Resume Next
'oh, one of the arrows points to the host cell as well!
colLinks.Remove rngCell.Address(External:=True)
If Not colLinks Is Nothing Then Set Get_LinksCell = colLinks
Set colLinks = Nothing
Set colLinksExt = Nothing
Set rngTemp = Nothing
Application.ScreenUpdating = True
Exit Function
ErrorH:
'error while calling 'NavigateArrow' method
If Err.Number = 1004 Then
'resume after 1st and 2nd error to process both same-sheet
' and external Precedents/Dependents
If Not lngErrorArrow > 2 Then
lngErrorArrow = lngErrorArrow + 1
Resume LoopArrows_Begin
End If
End If
'prevent perpetual loop
If lngErrorArrow > 3 Then Resume Finish
lngErrorArrow = lngErrorArrow + 1
Resume LoopArrows_End
End Function
'Returns a Collection of Range addresses for every Worksheet Link to another Workbook
' used in the formula argument
'Arguments: 'rngCellWithLinks' = the Cell Range containing the formula Link
'Written : 08-Dec-2003 by member Timbo @ visualbasicforum.com
Function Get_LinksFromFormula(rngCellWithLinks As Range)
Dim colReturn As New Collection
Dim lngStartChr As Long, lngEndChr As Long
Dim strFormulaTemp As String, strFilenameTemp As String, strAddress As String
Dim varLink
On Error GoTo ErrorH
'check parameters
Select Case False
Case rngCellWithLinks.Cells.Count = 1: GoTo Finish
Case rngCellWithLinks.HasFormula: GoTo Finish
End Select
strFormulaTemp = rngCellWithLinks.Formula
'determine if formula contains references to another Workbook
lngStartChr = Len(strFormulaTemp)
strFormulaTemp = Replace(strFormulaTemp, "[", "")
strFormulaTemp = Replace(strFormulaTemp, "]", "'")
'lngEndChr = Len(strFormulaTemp)
If lngStartChr = lngEndChr Then GoTo Finish
'build a collection object of links to other workbooks
For Each varLink In rngCellWithLinks.Parent.Parent.LinkSources(xlExcelLinks)
lngStartChr = InStr(1, strFormulaTemp, varLink)
If Not lngStartChr = 0 Then
lngEndChr = 1
strAddress = Mid(strFormulaTemp, lngStartChr + Len(varLink), lngEndChr)
On Error Resume Next
'add characters to the address string until a valid Range address is formed
Do Until TypeName(Range(strAddress)) = "Range"
strAddress = Mid(strFormulaTemp, lngStartChr + Len(varLink), lngEndChr)
lngEndChr = lngEndChr + 1
Loop
'continue adding to the address string until it no longer qualifies as a Range
If Not (lngStartChr + Len(varLink) + lngEndChr) > Len(strFormulaTemp) Then
Do Until Not IsNumeric(Right(strAddress, 1))
strAddress = Mid(strFormulaTemp, lngStartChr + Len(varLink), lngEndChr)
lngEndChr = lngEndChr + 1
Loop
'remove the trailing character
strAddress = Left(strAddress, Len(strAddress) - 1)
End If
On Error GoTo ErrorH
strFilenameTemp = rngCellWithLinks.Formula
'locate append filename to Range address
lngStartChr = InStr(lngStartChr, strFilenameTemp, "[")
lngEndChr = InStr(lngStartChr, strFilenameTemp, "]")
strAddress = Mid(strFilenameTemp, lngStartChr, lngEndChr - lngStartChr + 1) & strAddress
colReturn.Add strAddress, strAddress
End If
Next varLink
Set Get_LinksFromFormula = colReturn
Finish:
On Error Resume Next
Set colReturn = Nothing
Exit Function
ErrorH:
Resume Finish
End Function
来源：https://stackoverflow.com/questions/923684/how-do-you-test-that-a-range-in-excel-has-cells-in-it