Streamlining VBA code to remove two cell references

[ChristineJ]

I was provided the code below by a member on this forum a while back. I tweaked it a bit and have been using it successfully.

1. It looks at the formula in cell F19 and first removes any dollar signs and active worksheet names and returns that result in cell P31.
2. It then looks at the string in cell P31 and returns just the cell references in cell R31.
3. It then compares the cell references in R31 to those that are allowed and returns any cell references that not allowed in cell W31.

I'd like to accomplish this using variables for "Range("P31").Value and Range("R31").Value -- rather than having to have any values actually appear in those cells on the worksheet.

The formula in cell F19 is =SUM(D7+D8,E9)+CapCost!A1+$A$1
The code currently returns '=SUM(D7+D8,E9)+A1+A1 in cell P31
The code currently returns D7, D8, E9, A1, A1 in cell R31
The final result in cell W31 is E9, A1

The rest of it runs fine, as needed. I'd just like to see if it can be done without actually having anything entered in cell P31 or R31, using variables instead. Thanks!

Sub HelperCells()
    Dim xRetList As Object
    Dim xRegEx As Object
    Dim i As Long
    Dim xRet As String
    Dim allowedRange As Range
    Dim myRange As Range
    Dim T31 As String

   Application.ScreenUpdating = False
   Sheetname = ActiveSheet.Name & "!"

Range("P31").Value = "'" & Replace(Replace(Range("F19").Formula, "$", ""), Sheetname, "")
   
allowed = "D6,D7,D8,D9,D10,D11,D12,D13,D14" ' Allowable range
   
    'EXTRACT CELL REFERENCES FROM FORMULAS
    Set xRegEx = CreateObject("VBSCRIPT.REGEXP")
    With xRegEx
        .Pattern = "('?[a-zA-Z0-9\s\[\]\.]{1,99})?'?!?\$?[A-Z]{1,3}\$?[0-9]{1,7}(:\$?[A-Z]{1,3}\$?[0-9]{1,7})?"
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
    End With
       For Each rg In Range("P31")
   
    Set xRetList = xRegEx.Execute(rg.Formula)
    If xRetList.Count > 0 Then
        For i = 0 To xRetList.Count - 1
            xRet = xRet & xRetList.Item(i) & ", "
        Next
        rg.Offset(0, 2) = Left(xRet, Len(xRet) - 2)
    Else
        rg.Offset(0, 2) = ""
    End If
    xRet = ""
    Next rg

T31 = RemoveDupeWords(GetUnique(allowed & "", Range("R31").Value & ""), ", ")

Range("W31").Value = T31
  
   Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

I would highly recommend forcing yourself to always declare all variables. You can do that in the vba window with this once-only setting

Failing to do so can easily lead to incorrect code results with no warning.


See if this does what you want.

Sub NotAllowed()
  Dim xRegEx As Object, xMatch As Object, d As Object
  Dim allowed As String, Sheetname As String, s As String
  
  allowed = "D6,D7,D8,D9,D10,D11,D12,D13,D14" ' Allowable range
  Sheetname = ActiveSheet.Name & "!"
  Set d = CreateObject("Scripting.Dictionary")
  Set xRegEx = CreateObject("VBSCRIPT.REGEXP")
  With xRegEx
    .Pattern = "('?[a-zA-Z0-9\s\[\]\.]{1,99})?'?!?\$?[A-Z]{1,3}\$?[0-9]{1,7}(:\$?[A-Z]{1,3}\$?[0-9]{1,7})?"
    .Global = True
    For Each xMatch In .Execute(Replace(Replace(Range("F19").Formula, "$", ""), Sheetname, ""))
      If InStr(1, "," & allowed & ",", "," & xMatch & ",") = 0 And Not d.exists(CStr(xMatch)) Then
          s = s & ", " & xMatch
          d(CStr(xMatch)) = 1
      End If
    Next xMatch
  End With
  Range("W31").Value = Mid(s, 3)
End Sub

 

[johnnyL]

Slight assist to @Peter_SSs ...

Sub NotAllowed()
    Dim xRegEx As Object, xMatch As Object, d As Object
    Dim allowed As String, Sheetname As String, s As String
  
    allowed = "D6,D7,D8,D9,D10,D11,D12,D13,D14" ' Allowable range
    Sheetname = ActiveSheet.Name & "!"
    Set d = CreateObject("Scripting.Dictionary")
    Set xRegEx = CreateObject("VBSCRIPT.REGEXP")
    With xRegEx
        .Pattern = "('?[a-zA-Z0-9\s\[\]\.]{1,99})?'?!?\$?[A-Z]{1,3}\$?[0-9]{1,7}(:\$?[A-Z]{1,3}\$?[0-9]{1,7})?"
        .Global = True
        For Each xMatch In .Execute(Replace(Replace(Range("F19").Formula, "$", ""), Sheetname, ""))
            If InStr(1, "," & allowed & ",", "," & xMatch & ",") = 0 And Not d.exists(CStr(xMatch)) Then
                s = s & ", " & xMatch
                d(CStr(xMatch)) = 1
            End If
        Next xMatch
    End With
'
'   Assist
    s = Right$(s, Len(s) - 2)
    Range("W31") = s
End Sub

 

[Peter_SSs]

Slight assist to @Peter_SSs ...

Thanks for highlighting that I didn't quite copy all my code. However, your 'assist' will error in some circumstances.
I have edited my previous code to include all of it this time.

 

[ChristineJ]

I would highly recommend forcing yourself to always declare all variables. You can do that in the vba window with this once-only setting

View attachment 60989

Failing to do so can easily lead to incorrect code results with no warning.


See if this does what you want.

Sub NotAllowed()
  Dim xRegEx As Object, xMatch As Object, d As Object
  Dim allowed As String, Sheetname As String, s As String
 
  allowed = "D6,D7,D8,D9,D10,D11,D12,D13,D14" ' Allowable range
  Sheetname = ActiveSheet.Name & "!"
  Set d = CreateObject("Scripting.Dictionary")
  Set xRegEx = CreateObject("VBSCRIPT.REGEXP")
  With xRegEx
    .Pattern = "('?[a-zA-Z0-9\s\[\]\.]{1,99})?'?!?\$?[A-Z]{1,3}\$?[0-9]{1,7}(:\$?[A-Z]{1,3}\$?[0-9]{1,7})?"
    .Global = True
    For Each xMatch In .Execute(Replace(Replace(Range("F19").Formula, "$", ""), Sheetname, ""))
      If InStr(1, "," & allowed & ",", "," & xMatch & ",") = 0 And Not d.exists(CStr(xMatch)) Then
          s = s & ", " & xMatch
          d(CStr(xMatch)) = 1
      End If
    Next xMatch
  End With
  Range("W31")

Thank you so much - yes, this is what I needed. And I'll take your advice on declaring variables - still in the learning process. Appreciate the help, C

 

[Peter_SSs]

Thank you so much - yes, this is what I needed.

You're welcome.
Just check that you picked up my code edit only a few minutes ago. I had originally cut off the End Sub line and half the prvious line of code.

 

[ChristineJ]

I have been using the code posted by Peter SSs above on March 26 to get the result in W31 from the formula in F19, both below.

The formula in cell F19 is =SUM(D7+D8,E9)+CapCost!A1+$A$1
The final result in cell W31 is E9, A1

I realized there is one small issue. want the same result in W31 - E9, A1 - if the formula in cell F19 is =SUM(D7:D8,E9)+CapCost!A1+$A$1 where the original plus sign is instead a colon. However, it returns the following in W31: D7:D8, E9, A1

It there a way to adjust the code so it sees two separate cell references before and after the colon, if one is used, and allows those two cell references?

Thanks!

 

[Peter_SSs]

I have been using the code posted by Peter SSs above on March 26

In future, better to quote the post # rather than date. It was already March 27 here in Australia when you posted your original question so there are no posts on March 26 when I look at the thread.

It there a way to adjust the code so it sees two separate cell references before and after the colon, if one is used, and allows those two cell references?

Give this a test. I have added the red text.

Sub NotAllowed()
  Dim xRegEx As Object, xMatch As Object, d As Object
  Dim allowed As String, Sheetname As String, s As String
  
  allowed = "D6,D7,D8,D9,D10,D11,D12,D13,D14" ' Allowable range
  Sheetname = ActiveSheet.Name & "!"
  Set d = CreateObject("Scripting.Dictionary")
  Set xRegEx = CreateObject("VBSCRIPT.REGEXP")
  With xRegEx
    .Pattern = "('?[a-zA-Z0-9\s\[\]\.]{1,99})?'?!?\$?[A-Z]{1,3}\$?[0-9]{1,7}(:\$?[A-Z]{1,3}\$?[0-9]{1,7})?"
    .Global = True
    For Each xMatch In .Execute(Replace(Replace(Replace(Range("F19").Formula, ":", ","), "$", ""), Sheetname, ""))
      If InStr(1, "," & allowed & ",", "," & xMatch & ",") = 0 And Not d.exists(CStr(xMatch)) Then
          s = s & ", " & xMatch
          d(CStr(xMatch)) = 1
      End If
    Next xMatch
  End With
  Range("W31").Value = Mid(s, 3)
End Sub

 

[ChristineJ]

Thank you so much - it works as needed. Now that I see your update, I understand what I was doing wrong when I was trying to edit it myself.

Appreciate all your help on this and several other posts I have had this year. It is especially wonderful to know someone halfway around the world is assisting me! (Next time I will quote the post #!) Have a good evening! Sun is just rising here. Christine

 

[Peter_SSs]

Glad it worked for you. Thanks for your other comments too.

I'm not sure if it is important to you (or what could be done if it is) but suppose only D12, D13 and D14 were allowed and the formula was =SUM(D14:D17)
The above code will only report D17 as not allowed. It will not report D15 and D16 even though they are both included in the formula but not allowed.