Comment testez-vous qu'un Range dans Excel contient des cellules?

Question

J'ai trouvé un problème dans Excel/VBA dans l'événement Worksheet_Change. J'ai besoin d'assigner Target.Dependents à une plage, mais si elle n'a pas de dépendances, cela provoque une erreur. J'ai essayé de tester Target.Dependents.Cells.Count mais cela n'a pas fonctionné. Des idées?

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 

J'ai également essayé "Target.Dependents Is Nothing".

Answer 1

Réponse courte, il n'y a pas façon de tester les dépendances sans déclencher une erreur, car la propriété elle-même est définie pour déclencher une erreur si elle est accédée et il n'y en a pas. Je n'aime pas la conception mais il n'y a aucun moyen de l'empêcher sans supprimer les erreurs. AFAIK c'est à propos du meilleur que vous allez pouvoir faire avec lui.

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 

Explication, s'il n'y a pas de personnes à charge une erreur est déclenchée et la valeur de HasDependents reste inchangé par rapport à la valeur par défaut de type, ce qui est faux, ce faux est retourné. Si sont dépendants, la valeur de comptage ne sera jamais nulle. Tous les entiers non nuls sont convertis en vrai, donc lorsque count est assigné comme valeur de retour, true est renvoyé. C'est assez proche de ce que vous utilisez déjà.

Answer 2

Voici la seule façon que je trouve pour le faire fonctionner, mais j'aimerais une meilleure solution:

On Error Resume Next 
Dim TestRange As Range 
Set TestRange = Target.Dependents 

If TestRange.HasFormula And Err.Number = 0 Then ... 

Answer 3

Comme trouvé sur: 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