Related
i want to print value where background yellow is same as cell and background white is [0,0]
for this condition i want to get
[1,9],[0,0],[1,7],[1,6],[0,0],[1,4],[0,0],[1,2],[0,0]
I've written some code
Dim isect As Range
Set isect = Intersect(Target, Me.Range("$B$80:$J$80"))
If Not isect Is Nothing Then
Dim s As String
If Target.Interior.Color = vbYellow Then
s = Target.Value
Else
s = "[0,0]"
End If
Range("D96").Value = s
but it get only one value, what I should do for continuing.
Any help will be appreciated.
Dim isect As Range
Dim aCell As Range
Dim Output As String
Set isect = Intersect(target, Me.Range("$B$80:$J$80"))
If Not isect Is Nothing Then
For Each aCell In isect
If aCell.Interior.Color = vbYellow Then
Output = Output & "," & aCell.Value
Else
Output = Output & "," & "[0,0]"
End If
Next aCell
Range("D96") = Mid(Output, 2)
End If
Is this what you want?
Dependent on Cell Property (Fill Color)
Standard Module Code (e.g. Module1)
Option Explicit
Function getString(SourceRange As Range, _
Optional ByVal FillColor As Long = 0, _
Optional ByVal CriteriaNotMetValue As Variant = Empty, _
Optional ByVal Delimiter As String = ", ") _
As String
If SourceRange Is Nothing Then Exit Function
' Write values of range to array.
Dim Data As Variant
If SourceRange.Rows.Count > 1 Or SourceRange.Columns.Count > 1 Then
Data = SourceRange.Value
Else
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = SourceRange.Value
End If
' Modify values in array.
Dim i As Long, j As Long, Result As String
For i = 1 To UBound(Data)
For j = 1 To UBound(Data, 2)
If SourceRange.Cells(i, j).Interior.Color <> FillColor Then
Data(i, j) = CriteriaNotMetValue
End If
Result = Result & Delimiter & Data(i, j)
Next j
Next i
' Remove redundant Delimiter.
getString = Right(Result, Len(Result) - Len(Delimiter))
End Function
Sheet Code (e.g. Sheet1)
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const rngAddress As String = "B80:J80"
Const cellAddress As String = "D96"
Const CriteriaNotMetValue As Variant = "[0,0]"
Const FillColor As Long = vbYellow
Const Delimiter As String = ","
If Intersect(Me.Range(rngAddress), Target) Is Nothing Then Exit Sub
On Error GoTo clearError
Application.EnableEvents = False
Dim Result As String
Result = getString(Me.Range(rngAddress), FillColor, CriteriaNotMetValue, Delimiter)
Me.Range(cellAddress).Value = Result
CleanExit:
Application.EnableEvents = True
Exit Sub
clearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
On Error GoTo 0
GoTo CleanExit
End Sub
I want the values in Column D to change depending upon the value in Column A. Some values do not need to be amended at all if the conditions aren't met
Sub Test()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim row As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
I think I have an error in the lines beginning with c.Value = c.Value * .....
I'm new to VBA and just trying to make sense of it
I just provide this variant. It is working with array, so theoretically it is very quick. Probably no need to turn off the screen updating.
Sub test()
Dim lastRow As Long, i As Long
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
Dim vA As Variant 'Represents A2-A lastrow
vA = .Range("A2").Resize(lastRow - 1).Value
Dim vb As Variant 'Represents D2-D lastrow
vb = .Range("D2").Resize(lastRow - 1).Value
i = 0
Dim v As Variant
For Each v In vA
i = i + 1
If v = "Bol" Then
vb(i, 1) = vb(i, 1) * 1.19
ElseIf v = "Amazon" Then
vb(i, 1) = vb(i, 1) * 1.2
End If
Next v
.Range("D2").Resize(lastRow - 1).Value = vb ' Writing the values to the D column
End With
End Sub
You have to forecast and handle all possible conditions. Use this code please:
Sub Test()
Application.ScreenUpdating = False
Dim row As Integer
Dim Lastrow As Long
'I've assumed that you are working on sheet1
Lastrow = Sheets(1).Cells(Rows.Count, "D").End(xlUp).row
If Lastrow > 1 Then
For row = 2 To Lastrow
If Sheets(1).Cells(row, 1).Value = "Bol" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.19
End If
If Sheets(1).Cells(row, 1).Value = "Amazon" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.2
End If
Next
Else
MsgBox ("There is no data at column D")
End If
Application.ScreenUpdating = True
End Sub
There are quite a few ways to go about what you're trying to do. For what it's worth, this is how I would go about it. You had a few additional variables you didn't need, and your 'row' variable wasn't assigned a value at all.
Sub test2()
Dim lastRow As Long, _
i As Long
Application.ScreenUpdating = False
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
For i = 2 To lastRow
If .Cells(i, 1).Value = "Bol" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.19
End If
If .Cells(i, 1).Value = "Amazon" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.2
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
I kept is relatively simple, so hopefully you can follow what's going on. If you have a lot of "If" statements, it may be cleaner to use VBAs "Select Case".
Also the text strings as you have them set up are case sensitive. "Bol" does not equal "bol" maybe that doesn't matter, but something to be aware of. If the string you pass it is "amazon" it will not pass the 'If' test.
Another assumption I made was that your data is on Sheet1. You should get in the habit of fully qualifying your ranges, it will make your life a lot easier as your code gets more complicated.
Last bit, I'm assuming the values in column D are all numbers. If there is text in there, you may run in to problems multiplying it.
Good luck!
You can simplify your code, and make it easier to read, by looping trough column A instead of column D and using the If/ElseIf statement to test each cell for either of the two conditions. By setting your range and defining c as a range variable for each cell in the range, you only have to loop through each cell and test for the two conditions. If the cell contains Bol use the Offset property to multiple the current value in column D by 1.19; ElseIf the cell contains Amazon use the Offset property to multiple the current value in column D by 1.2. Comments provide in the code.
Application.ScreenUpdating = False
'use the With statement to define your workbook and sheet, change as needed
'Note: "ThisWorkbook" identifies the workbook which contains this code
With ThisWorkbook.Sheets("Sheet1")
'Define the range you want to loop through, using the column you want to test
Dim rng As Range: Set rng = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
'Define the variable for each cell-range
Dim c As Range
'loop through each "c" in the range and if one of the conditions are met
For Each c In rng
If c = "Bol" Then
'then use the "Offset property" to modify the value in column D
c.Offset(, 3) = c.Offset(, 3).Value * 1.19
ElseIf c = "Amazon" Then
c.Offset(, 3) = c.Offset(, 3).Value * 1.2
End If
Next c
End With
Application.ScreenUpdating = True
In-Place Modification
All the solutions have one common issue: you can use them only once. If you need to change the values after adding new records (rows) you should consider adding another column with the initial values so the code could be written to identify what has already been changed and what not. But that's for another question.
Your Sub Solution
You actually had only one serious mistake in two-three places.
Instead of row in the If statements you should have used c.Row and you could have removed Dim row As Integer:
Sub Test_Almost_Fixed()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
Additionally after getting rid of the extra Application.ScreenUpdating = False and the Dim startrow As Integer and some further cosmetics, you could have had something like this:
Sub Test_Fixed()
Dim c As Range
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
Application.ScreenUpdating = False
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
A More Complex Sub Solution
Use the following for the ActiveSheet in a standard module (e.g. Module1). For a particular sheet you can place it in a sheet module (e.g. Sheet1) or create a button on the sheet.
Tip: When you have such a simple (short, fast) code and especially when you're using a Button to run it (in a 'one-time operation code'), it is good practice to use a MsgBox at the end of the code to actually know that the code has run and to prevent accidentally pressing the Button more than once.
Option Explicit
Sub Test()
Const Proc As String = "Test"
On Error GoTo cleanError
' Define Constants.
Const FirstRow As Long = 2
Const SourceColumn As Variant = 1 ' e.g. 1 or "A"
Const TargetColumn As Variant = 4 ' e.g. 4 or "D"
Dim Criteria As Variant ' Add more values.
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant ' Add more values.
Multiplier = Array(1.19, 1.2)
' Check if Criteria and Multiplier Arrays have the same number
' of elements (columns).
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
' Write Source and Target Ranges to Source and Target Arrays.
Dim rng As Range
' Define Last Non-Empty Cell.
Set rng = Columns(TargetColumn).Find("*", , xlValues, , , xlPrevious)
' Check if Target Column is empty.
If rng Is Nothing Then Exit Sub
' Check if the row of Last Non-Empty Cell is above FirstRow.
If rng.Row < FirstRow Then Exit Sub
Dim Target As Variant
' Write Target Range to Target Array.
Target = Range(Cells(FirstRow, TargetColumn), rng).Value
Set rng = Nothing
Dim ubST As Long: ubST = UBound(Target)
Dim Source As Variant
' Write Source Range to Source Array.
Source = Cells(FirstRow, SourceColumn).Resize(ubST).Value
' Modify Target Array.
Dim i As Long, j As Long
' Loop through elements (rows) of Source and Target Arrays.
For i = 1 To ubST
' Loop through elements (columns) of Criteria and Multiplier Arrays.
For j = 0 To ubCM
' Check if the value in current element (row) of Source Array
' matches the value of current element (column) in Criteria Array.
If Source(i, 1) = Criteria(j) Then
' Modify value in current element (row) of Target Array
' by multiplying it with the value of current element (column)
' of Multiplier Array.
Target(i, 1) = Target(i, 1) * Multiplier(j)
' Since a match is found, there is no need to loop anymore.
Exit For
End If
Next j
Next i
Erase Source
' Write values of Target Array to Target Range.
Cells(FirstRow, TargetColumn).Resize(ubST).Value = Target
Erase Target
' Inform user.
MsgBox "Data copied.", vbInformation, "Success"
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
End Sub
An Event Solution
To make it automatically change the values in column D for each change of a value in column A you can place the following code into the sheet module (e.g. Sheet1):
Option Explicit
Private Const SOURCE_COLUMN As Variant = 1 ' e.g. 1 or "A"
Private Const TARGET_COLUMN As Variant = 4 ' e.g. 4 or "D"
Private Sub sdfWorksheet_Change(ByVal Target As Range)
Const Proc As String = "Worksheet_Change"
On Error GoTo cleanError
If Intersect(Columns(SOURCE_COLUMN), Target) Is Nothing Then Exit Sub
Const FirstRow As Long = 2
Dim rng As Range
Set rng = Columns(TARGET_COLUMN).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRow Then Exit Sub
Set rng = Cells(FirstRow, SOURCE_COLUMN).Resize(rng.row - FirstRow + 1)
If Intersect(rng, Target) Is Nothing Then Exit Sub
Dim cel As Range
Application.Calculation = xlCalculationManual ' -4135
For Each cel In Target.Cells
TestChange cel
Next cel
CleanExit:
Application.Calculation = xlCalculationAutomatic ' -4105
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
Private Sub TestChange(SourceCell As Range)
Const Proc As String = "TestChange"
On Error GoTo cleanError
Dim Criteria As Variant
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant
Multiplier = Array(1.19, 1.2)
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
Application.ScreenUpdating = False
Dim TargetCell As Range, j As Long
For j = 0 To ubCM
If SourceCell.Value = Criteria(j) Then
Set TargetCell = Cells(SourceCell.row, TARGET_COLUMN)
TargetCell.Value = TargetCell.Value * Multiplier(j)
Exit For
End If
Next j
CleanExit:
Application.ScreenUpdating = True
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
I have a list of 594 named ranges in a workbook with nearly 20 sheets, each sheet has about 200 columns of data. I need to find out where the named ranges are being used so as to remove irrelevant ones. I pasted a list of named ranges onto the sheet and then I tried to find if they were used in a formula by recording them, and then using the find method in all sheets and columns. The problem is despite using lookin xlformulas, it retrieves the named range even if it is just a text.
Here is my (updated) attempt (if it is not evident already, i am an amateur):
Application.ScreenUpdating = False
Count = ActiveWorkbook.Sheets.Count
Sheets(Count).Activate
Dim locr(1 To 595)
Dim locc(1 To 595)
Dim locn(1 To 595)
Dim nam(1 To 595)
Dim rng As Range
Range("a1").Select
For X = 1 To 595 'populate array with named ranges
ActiveCell.Offset(1, 0).Select
nam(X) = ActiveCell.Value
Next X
For i = 1 To 595 'name loop
For j = 1 To (Count - 1) 'sheet loop
Sheets(j).Activate
On Error Resume Next
Set orange = Sheets(j).Cells.SpecialCells(xlCellTypeFormulas) 'limit range to cells that only contain formulas
On Error GoTo 20 'if no formulas in sheet, go to next sheet
If Not orange Is Nothing Then
Set rng = orange.Find(What:=nam(i), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False) 'find named range
If Not rng Is Nothing Then 'if named range found
Application.Goto rng, True 'go to cell where name range found and record address
locr(i) = ActiveCell.Row
locc(i) = ActiveCell.Column
locn(i) = ActiveSheet.Name
GoTo 10 'value found, go to next sheet
Else
End If
Else
End If
20 Next j
locr(i) = "" 'record empty since "rng" is empty
locr(i) = ""
locr(i) = ""
10 Next i
Sheets(Count).Activate
Range("c1").Select
b = 1
For a = 1 To 595 'populate addresses of named ranges
ActiveCell.Offset(b, 2).Value = locr(a)
ActiveCell.Offset(b, 1).Value = locc(a)
ActiveCell.Offset(b, 0).Value = locn(a)
b = b + 1
Next a
Here is one way I can think of. I will explain this in 2 parts.
PART 1
Let's say we have a named range Sid.
This word Sid can appear in any one of these forms as shown in the image below. Why does it start with =? That has been explained in Part2 below.
=Sid '<~~ 1
="Sid" '<~~ 2
=XSid '<~~ 3
=SidX '<~~ 4
=_Sid '<~~ 5
=Sid_ '<~~ 6
=(Sid) '<~~ 7
Any other scenarios, I guess will be a subset of the above. Now out of these the only valid find in our case is the first one and the last one since we are looking for our named range.
So here is a quick function to check if the cell formula has a named range or not. I am sure it can be made more efficient
Function isNamedRangePresent(rng As Range, s As String) As Boolean
Dim sFormula As String
Dim pos1 As Long, pos2 As Long, sLen As Long, i As Long
sFormula = rng.Formula: sLen = Len(sFormula)
pos2 = 1
Do
pos1 = InStr(pos2, sFormula, s) - 1
If pos1 < 1 Then Exit Do
isNamedRangePresent = True
For i = 65 To 90
'~~> A-Z before Sid for example XSid
If UCase(Mid(sFormula, pos1, 1)) = Chr(i) Then
isNamedRangePresent = False
Exit For
End If
Next i
'~~> Check for " for example "Sid
If isNamedRangePresent = True Then _
If UCase(Mid(sFormula, pos1, 1)) = Chr(34) Then isNamedRangePresent = False
'~~> Check for underscore for example _Sid
If isNamedRangePresent = True Then _
If UCase(Mid(sFormula, pos1, 1)) = Chr(95) Then isNamedRangePresent = False
pos2 = pos1 + Len(s) + 1
If pos2 <= sLen Then
For i = 65 To 90
'~~> A-Z after Sid for example SidX
If UCase(Mid(sFormula, pos2, 1)) = Chr(i) Then
isNamedRangePresent = False
Exit For
End If
Next i
'~~> "Sid
If isNamedRangePresent = True Then _
If UCase(Mid(sFormula, pos2, 1)) = Chr(34) Then isNamedRangePresent = False
'~~> _Sid
If isNamedRangePresent = True Then _
If UCase(Mid(sFormula, pos2, 1)) = Chr(95) Then isNamedRangePresent = False
End If
Loop
End Function
So in the first and the last case, Debug.Print isNamedRangePresent(Range("D2"), "Sid") will give you True See this
PART 2
Now coming to the .Find. I see that you are searching only once in the worksheet. Since you can have many scenarios of the word Sid being present, you cannot just have one .Find. You will have to use .FindNext. See THIS link on how to use that. I have explained it there so I won't bother explaining that here.
We can make our .Find more efficient by searching only those cells which has formulas. To do that we have to use .SpecialCells(xlCellTypeFormulas). This explains why we had "=" in our example in PART1. :)
Here is an example (PART1 Code added at the bottom)
Sub Sample()
Dim oRange As Range, aCell As Range, bCell As Range
Dim oSht As Worksheet
Dim strSearch As String, FoundAt As String
Set oSht = Worksheets("Sheet1")
'~~> Set your range where you need to find - Only Formula Cells
On Error Resume Next
Set oRange = oSht.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not oRange Is Nothing Then
strSearch = "Sid"
Set aCell = oRange.Find(What:=strSearch, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
'~~> Check if the cell has named range
If isNamedRangePresent(aCell, strSearch) Then FoundAt = aCell.Address
Do
Set aCell = oRange.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
'~~> Check if the cell has named range
If isNamedRangePresent(aCell, strSearch) Then FoundAt = FoundAt & ", " & aCell.Address
Else
Exit Do
End If
Loop
Else
MsgBox SearchString & " not Found"
Exit Sub
End If
If FoundAt = "" Then
MsgBox "The Named Range was not found"
Else
MsgBox "The Named Range has been found these locations: " & FoundAt
End If
End If
End Sub
Function isNamedRangePresent(rng As Range, s As String) As Boolean
Dim sFormula As String
Dim pos1 As Long, pos2 As Long, sLen As Long, i As Long
sFormula = rng.Formula: sLen = Len(sFormula)
pos2 = 1
Do
pos1 = InStr(pos2, sFormula, s) - 1
If pos1 < 1 Then Exit Do
isNamedRangePresent = True
For i = 65 To 90
'~~> A-Z before Sid for example XSid
If UCase(Mid(sFormula, pos1, 1)) = Chr(i) Then
isNamedRangePresent = False
Exit For
End If
Next i
'~~> Check for " for example "Sid
If isNamedRangePresent = True Then _
If UCase(Mid(sFormula, pos1, 1)) = Chr(34) Then isNamedRangePresent = False
'~~> Check for underscore for example _Sid
If isNamedRangePresent = True Then _
If UCase(Mid(sFormula, pos1, 1)) = Chr(95) Then isNamedRangePresent = False
pos2 = pos1 + Len(s) + 1
If pos2 <= sLen Then
For i = 65 To 90
'~~> A-Z after Sid for example SidX
If UCase(Mid(sFormula, pos2, 1)) = Chr(i) Then
isNamedRangePresent = False
Exit For
End If
Next i
'~~> "Sid
If isNamedRangePresent = True Then _
If UCase(Mid(sFormula, pos2, 1)) = Chr(34) Then isNamedRangePresent = False
'~~> _Sid
If isNamedRangePresent = True Then _
If UCase(Mid(sFormula, pos2, 1)) = Chr(95) Then isNamedRangePresent = False
End If
Loop
End Function
Output
PHEW!!!
This code creates a copy of the workbook with the names. It then goes through and deletes each name in your list of names from the that copied workbook. It counts up the number of formula errors in the workbook before and after. If the error count is the same, the name wasn't used. If it's different, the name was used.
I like to do this kind of test for really complicated situations like this. It means you don't have to worry so much about complicated rules for testing. You can just base your answer on the results.
Since the testing is all done on a copy, it should be safe. Be sure to save all your work before though!
To use, put put your list of names in a workbook and name the range with that list "NamesToTest":
Then put this code in the same workbook and run it:
Sub CheckNameUsage()
Dim WorkbookWithList As Excel.Workbook
Dim WorkbookWithNames As Excel.Workbook
Dim TempWb As Excel.Workbook
Dim cell As Excel.Range
Dim NameToCheck As String
Dim ws As Excel.Worksheet
Dim ErrorRange As Excel.Range
Dim ErrorsBefore As Long
Dim ErrorsAfter As Long
Dim NameUsed As Boolean
Set WorkbookWithList = ThisWorkbook
Set WorkbookWithNames = Workbooks("SO - wb to test.xlsx") 'adjust to suit
WorkbookWithNames.Worksheets.Copy 'Workbooks.Add(WorkbookWithNames.FullName)
Set TempWb = ActiveWorkbook
For Each cell In WorkbookWithList.Names("NamesToTest").RefersToRange.Cells
NameToCheck = cell.Value
ErrorsBefore = 0
For Each ws In TempWb.Worksheets
Set ErrorRange = Nothing
On Error Resume Next
Set ErrorRange = ws.Cells.SpecialCells(xlCellTypeFormulas, 16)
On Error GoTo 0
If Not ErrorRange Is Nothing Then
ErrorsBefore = ErrorsBefore + ErrorRange.Cells.Count
End If
Next ws
TempWb.Names(NameToCheck).Delete
ErrorsAfter = 0
For Each ws In TempWb.Worksheets
Set ErrorRange = Nothing
On Error Resume Next
Set ErrorRange = ws.Cells.SpecialCells(xlCellTypeFormulas, 16)
On Error GoTo 0
If Not ErrorRange Is Nothing Then
ErrorsAfter = ErrorsAfter + ErrorRange.Cells.Count
End If
Next ws
NameUsed = True
If ErrorsBefore = ErrorsAfter Then
NameUsed = False
End If
Debug.Print NameToCheck; " - Errors Before = " & ErrorsBefore; ", Errors After = " & ErrorsAfter; ", Used = " & NameUsed; ""
Next cell
TempWb.Close False
End Sub
The results will show in the Debug window:
The code is hopefully fairly self-explanatory. SpecialCells is worth knowing about, so read up on it if necessary. In this case it identifies cells with errors - that's the 16 argument.
Note that this only checks for workbook-level names. You could add checks for worksheet-level if necessary.
The following code works for me. The interesting points are
1) You can use the method range.ShowDependents to draw arrows to cells that are dependent on that range. When you are done, use range.ShowDependents True to remove the arrows.
2) Once the arrows are drawn, range.NavigateArrow can follow those arrows, and return the resulting range. I was unable to find any documentation on what happens if there are no dependent ranges. By experimenting, I was able to determine, that it will return the original range if there are no dependents.
Sub test_for_dependents(nm As Name)
Dim nm_rng As Range, result As Range
Dim i As Long
Set nm_rng = nm.RefersToRange
nm_rng.ShowDependents
Set result = nm_rng.NavigateArrow(False, 1, 1)
If result.Parent.Name = nm_rng.Parent.Name And result.Row = nm_rng.Row _
And result.Column = nm_rng.Column Then
MsgBox "Named range """ & nm.Name & """ isn't used!"
End If
nm_rng.ShowDependents True
Set nm_rng = Nothing
Set result = Nothing
End Sub
Sub test_all_names()
Dim nm As Name
Dim sht As Worksheet
For Each nm In ThisWorkbook.Names
test_for_dependents nm
Next nm
For Each sht In ThisWorkbook.Sheets
For Each nm In sht.Names
test_for_dependents nm
Next nm
Next sht
Set nm = Nothing
Set sht = Nothing
End Sub
The following NamesInCells macro reports the number of formula cells referencing each defined name (named range) in the active workbook. Results are in columns A:D (Scope, Name, RefersTo, Cells) starting at row 1 of the workbook's NamesInCells worksheet. If that worksheet does not exist, it will be added after the last sheet.
For each Name that is Visible (not hidden), the macro uses Private Function Formula_Errors to determine how many formula cells have errors before and after the Name's RefersTo property is made invalid. The before and after difference is the number of cells referencing that Name in a formula. However, if a Name is used in a cell formula that produced an error before, the after result will be the same for that cell. This issue is resolved by Private Function Prior_Errors which determines if the Name appears in an error cell's formula before the Name was made invalid. The InStr method used by Prior_Errors is imperfect, but only for formulas that had errors before initiating the macro (hopefully few). Also, a Name with workbook scope and a duplicate Name with sheet scope might be extraneously counted if they are in separate formulas that had initial errors.
This macro was inspired by Doug Glancy's answer above: https://stackoverflow.com/a/26691025/10172433
Public Sub NamesInCells()
Const myName As String = "NamesInCells"
Dim WB As Workbook, oName As Name, A() As Variant, vCells As Variant
Dim sScope As String, sName As String, sRefersTo As String
Dim nRows As Long, nR As Long, nBase As Long, n As Integer
Set WB = ActiveWorkbook
nRows = WB.Names.Count
If nRows = 0 Then
MsgBox "There are no defined names in the active workbook", _
vbInformation, myName
Exit Sub
End If
nRows = nRows + 1
ReDim A(1 To 4, 1 To nRows)
nR = 1
A(1, 1) = "Scope"
A(2, 1) = "Name"
A(3, 1) = "RefersTo"
A(4, 1) = "Cells"
nBase = Formula_Errors(WB)
For Each oName In WB.Names
With oName
If .Visible Then 'skip hidden names
n = InStrRev(.Name, "!")
If n = 0 Then
sScope = "Workbook"
sName = .Name
ElseIf n > 1 Then
sScope = Left(.Name, (n - 1))
sName = Mid(.Name, (n + 1))
End If
sRefersTo = .RefersTo
If Left(sScope, 1) = "'" Then _
sScope = Mid(sScope, 2, (Len(sScope) - 2))
.RefersTo = "#REF!"
vCells = Formula_Errors(WB) - nBase
.RefersTo = sRefersTo
vCells = vCells + Prior_Errors(WB, .Name)
nR = nR + 1
A(1, nR) = sScope
A(2, nR) = sName
A(3, nR) = "'" & sRefersTo
A(4, nR) = vCells
End If
End With
Next oName
If nR < 2 Then
MsgBox "There are no visible defined names in the active workbook", _
vbInformation, myName
Exit Sub
ElseIf nR < nRows Then
ReDim Preserve A(1 To 4, 1 To nR)
End If
On Error Resume Next
With WB
.Worksheets(myName).Activate
If Err = 0 Then
Range("A:D").Clear
Else
.Worksheets.Add After:=.Sheets(.Sheets.Count)
ActiveSheet.Name = myName
End If
End With
On Error GoTo 0
Range("A1").Select
Selection.Resize(nR, 4).Value = Application.Transpose(A)
End Sub
Private Function Formula_Errors(WB As Workbook) As Long
Dim WS As Worksheet, R As Range, nCount As Long
For Each WS In WB.Worksheets
On Error Resume Next
Set R = WS.Cells.SpecialCells(xlCellTypeFormulas, xlErrors)
If Err = 0 Then nCount = nCount + R.Count
On Error GoTo 0
Next WS
Formula_Errors = nCount
End Function
Private Function Prior_Errors(WB As Workbook, Name As String) As Long
Dim WS As Worksheet, R As Range, rCell As Range, nCount As Long
Dim sWS As String, sN As String, sF As String, n As Integer
n = InStrRev(Name, "!")
If n > 1 Then
sN = Mid(Name, (n + 1))
sWS = Left(Name, (n - 1))
If Left(sWS, 1) = "'" Then sWS = Mid(sWS, 2, (Len(sWS) - 2))
End If
For Each WS In WB.Worksheets
On Error Resume Next
Set R = WS.Cells.SpecialCells(xlCellTypeFormulas, xlErrors)
If Err = 0 Then
For Each rCell In R
sF = rCell.Formula
If WS.Name = sWS Then
If InStr(1, sF, sN, vbBinaryCompare) > 0 Then
nCount = nCount + 1
End If
ElseIf InStr(1, sF, Name, vbBinaryCompare) > 0 Then
nCount = nCount + 1
End If
Next rCell
End If
On Error GoTo 0
Next WS
Prior_Errors = nCount
End Function
I have a list of 594 named ranges in a workbook with nearly 20 sheets, each sheet has about 200 columns of data. I need to find out where the named ranges are being used so as to remove irrelevant ones. I pasted a list of named ranges onto the sheet and then I tried to find if they were used in a formula by recording them, and then using the find method in all sheets and columns. The problem is despite using lookin xlformulas, it retrieves the named range even if it is just a text.
Here is my (updated) attempt (if it is not evident already, i am an amateur):
Application.ScreenUpdating = False
Count = ActiveWorkbook.Sheets.Count
Sheets(Count).Activate
Dim locr(1 To 595)
Dim locc(1 To 595)
Dim locn(1 To 595)
Dim nam(1 To 595)
Dim rng As Range
Range("a1").Select
For X = 1 To 595 'populate array with named ranges
ActiveCell.Offset(1, 0).Select
nam(X) = ActiveCell.Value
Next X
For i = 1 To 595 'name loop
For j = 1 To (Count - 1) 'sheet loop
Sheets(j).Activate
On Error Resume Next
Set orange = Sheets(j).Cells.SpecialCells(xlCellTypeFormulas) 'limit range to cells that only contain formulas
On Error GoTo 20 'if no formulas in sheet, go to next sheet
If Not orange Is Nothing Then
Set rng = orange.Find(What:=nam(i), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False) 'find named range
If Not rng Is Nothing Then 'if named range found
Application.Goto rng, True 'go to cell where name range found and record address
locr(i) = ActiveCell.Row
locc(i) = ActiveCell.Column
locn(i) = ActiveSheet.Name
GoTo 10 'value found, go to next sheet
Else
End If
Else
End If
20 Next j
locr(i) = "" 'record empty since "rng" is empty
locr(i) = ""
locr(i) = ""
10 Next i
Sheets(Count).Activate
Range("c1").Select
b = 1
For a = 1 To 595 'populate addresses of named ranges
ActiveCell.Offset(b, 2).Value = locr(a)
ActiveCell.Offset(b, 1).Value = locc(a)
ActiveCell.Offset(b, 0).Value = locn(a)
b = b + 1
Next a
Here is one way I can think of. I will explain this in 2 parts.
PART 1
Let's say we have a named range Sid.
This word Sid can appear in any one of these forms as shown in the image below. Why does it start with =? That has been explained in Part2 below.
=Sid '<~~ 1
="Sid" '<~~ 2
=XSid '<~~ 3
=SidX '<~~ 4
=_Sid '<~~ 5
=Sid_ '<~~ 6
=(Sid) '<~~ 7
Any other scenarios, I guess will be a subset of the above. Now out of these the only valid find in our case is the first one and the last one since we are looking for our named range.
So here is a quick function to check if the cell formula has a named range or not. I am sure it can be made more efficient
Function isNamedRangePresent(rng As Range, s As String) As Boolean
Dim sFormula As String
Dim pos1 As Long, pos2 As Long, sLen As Long, i As Long
sFormula = rng.Formula: sLen = Len(sFormula)
pos2 = 1
Do
pos1 = InStr(pos2, sFormula, s) - 1
If pos1 < 1 Then Exit Do
isNamedRangePresent = True
For i = 65 To 90
'~~> A-Z before Sid for example XSid
If UCase(Mid(sFormula, pos1, 1)) = Chr(i) Then
isNamedRangePresent = False
Exit For
End If
Next i
'~~> Check for " for example "Sid
If isNamedRangePresent = True Then _
If UCase(Mid(sFormula, pos1, 1)) = Chr(34) Then isNamedRangePresent = False
'~~> Check for underscore for example _Sid
If isNamedRangePresent = True Then _
If UCase(Mid(sFormula, pos1, 1)) = Chr(95) Then isNamedRangePresent = False
pos2 = pos1 + Len(s) + 1
If pos2 <= sLen Then
For i = 65 To 90
'~~> A-Z after Sid for example SidX
If UCase(Mid(sFormula, pos2, 1)) = Chr(i) Then
isNamedRangePresent = False
Exit For
End If
Next i
'~~> "Sid
If isNamedRangePresent = True Then _
If UCase(Mid(sFormula, pos2, 1)) = Chr(34) Then isNamedRangePresent = False
'~~> _Sid
If isNamedRangePresent = True Then _
If UCase(Mid(sFormula, pos2, 1)) = Chr(95) Then isNamedRangePresent = False
End If
Loop
End Function
So in the first and the last case, Debug.Print isNamedRangePresent(Range("D2"), "Sid") will give you True See this
PART 2
Now coming to the .Find. I see that you are searching only once in the worksheet. Since you can have many scenarios of the word Sid being present, you cannot just have one .Find. You will have to use .FindNext. See THIS link on how to use that. I have explained it there so I won't bother explaining that here.
We can make our .Find more efficient by searching only those cells which has formulas. To do that we have to use .SpecialCells(xlCellTypeFormulas). This explains why we had "=" in our example in PART1. :)
Here is an example (PART1 Code added at the bottom)
Sub Sample()
Dim oRange As Range, aCell As Range, bCell As Range
Dim oSht As Worksheet
Dim strSearch As String, FoundAt As String
Set oSht = Worksheets("Sheet1")
'~~> Set your range where you need to find - Only Formula Cells
On Error Resume Next
Set oRange = oSht.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not oRange Is Nothing Then
strSearch = "Sid"
Set aCell = oRange.Find(What:=strSearch, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
'~~> Check if the cell has named range
If isNamedRangePresent(aCell, strSearch) Then FoundAt = aCell.Address
Do
Set aCell = oRange.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
'~~> Check if the cell has named range
If isNamedRangePresent(aCell, strSearch) Then FoundAt = FoundAt & ", " & aCell.Address
Else
Exit Do
End If
Loop
Else
MsgBox SearchString & " not Found"
Exit Sub
End If
If FoundAt = "" Then
MsgBox "The Named Range was not found"
Else
MsgBox "The Named Range has been found these locations: " & FoundAt
End If
End If
End Sub
Function isNamedRangePresent(rng As Range, s As String) As Boolean
Dim sFormula As String
Dim pos1 As Long, pos2 As Long, sLen As Long, i As Long
sFormula = rng.Formula: sLen = Len(sFormula)
pos2 = 1
Do
pos1 = InStr(pos2, sFormula, s) - 1
If pos1 < 1 Then Exit Do
isNamedRangePresent = True
For i = 65 To 90
'~~> A-Z before Sid for example XSid
If UCase(Mid(sFormula, pos1, 1)) = Chr(i) Then
isNamedRangePresent = False
Exit For
End If
Next i
'~~> Check for " for example "Sid
If isNamedRangePresent = True Then _
If UCase(Mid(sFormula, pos1, 1)) = Chr(34) Then isNamedRangePresent = False
'~~> Check for underscore for example _Sid
If isNamedRangePresent = True Then _
If UCase(Mid(sFormula, pos1, 1)) = Chr(95) Then isNamedRangePresent = False
pos2 = pos1 + Len(s) + 1
If pos2 <= sLen Then
For i = 65 To 90
'~~> A-Z after Sid for example SidX
If UCase(Mid(sFormula, pos2, 1)) = Chr(i) Then
isNamedRangePresent = False
Exit For
End If
Next i
'~~> "Sid
If isNamedRangePresent = True Then _
If UCase(Mid(sFormula, pos2, 1)) = Chr(34) Then isNamedRangePresent = False
'~~> _Sid
If isNamedRangePresent = True Then _
If UCase(Mid(sFormula, pos2, 1)) = Chr(95) Then isNamedRangePresent = False
End If
Loop
End Function
Output
PHEW!!!
This code creates a copy of the workbook with the names. It then goes through and deletes each name in your list of names from the that copied workbook. It counts up the number of formula errors in the workbook before and after. If the error count is the same, the name wasn't used. If it's different, the name was used.
I like to do this kind of test for really complicated situations like this. It means you don't have to worry so much about complicated rules for testing. You can just base your answer on the results.
Since the testing is all done on a copy, it should be safe. Be sure to save all your work before though!
To use, put put your list of names in a workbook and name the range with that list "NamesToTest":
Then put this code in the same workbook and run it:
Sub CheckNameUsage()
Dim WorkbookWithList As Excel.Workbook
Dim WorkbookWithNames As Excel.Workbook
Dim TempWb As Excel.Workbook
Dim cell As Excel.Range
Dim NameToCheck As String
Dim ws As Excel.Worksheet
Dim ErrorRange As Excel.Range
Dim ErrorsBefore As Long
Dim ErrorsAfter As Long
Dim NameUsed As Boolean
Set WorkbookWithList = ThisWorkbook
Set WorkbookWithNames = Workbooks("SO - wb to test.xlsx") 'adjust to suit
WorkbookWithNames.Worksheets.Copy 'Workbooks.Add(WorkbookWithNames.FullName)
Set TempWb = ActiveWorkbook
For Each cell In WorkbookWithList.Names("NamesToTest").RefersToRange.Cells
NameToCheck = cell.Value
ErrorsBefore = 0
For Each ws In TempWb.Worksheets
Set ErrorRange = Nothing
On Error Resume Next
Set ErrorRange = ws.Cells.SpecialCells(xlCellTypeFormulas, 16)
On Error GoTo 0
If Not ErrorRange Is Nothing Then
ErrorsBefore = ErrorsBefore + ErrorRange.Cells.Count
End If
Next ws
TempWb.Names(NameToCheck).Delete
ErrorsAfter = 0
For Each ws In TempWb.Worksheets
Set ErrorRange = Nothing
On Error Resume Next
Set ErrorRange = ws.Cells.SpecialCells(xlCellTypeFormulas, 16)
On Error GoTo 0
If Not ErrorRange Is Nothing Then
ErrorsAfter = ErrorsAfter + ErrorRange.Cells.Count
End If
Next ws
NameUsed = True
If ErrorsBefore = ErrorsAfter Then
NameUsed = False
End If
Debug.Print NameToCheck; " - Errors Before = " & ErrorsBefore; ", Errors After = " & ErrorsAfter; ", Used = " & NameUsed; ""
Next cell
TempWb.Close False
End Sub
The results will show in the Debug window:
The code is hopefully fairly self-explanatory. SpecialCells is worth knowing about, so read up on it if necessary. In this case it identifies cells with errors - that's the 16 argument.
Note that this only checks for workbook-level names. You could add checks for worksheet-level if necessary.
The following code works for me. The interesting points are
1) You can use the method range.ShowDependents to draw arrows to cells that are dependent on that range. When you are done, use range.ShowDependents True to remove the arrows.
2) Once the arrows are drawn, range.NavigateArrow can follow those arrows, and return the resulting range. I was unable to find any documentation on what happens if there are no dependent ranges. By experimenting, I was able to determine, that it will return the original range if there are no dependents.
Sub test_for_dependents(nm As Name)
Dim nm_rng As Range, result As Range
Dim i As Long
Set nm_rng = nm.RefersToRange
nm_rng.ShowDependents
Set result = nm_rng.NavigateArrow(False, 1, 1)
If result.Parent.Name = nm_rng.Parent.Name And result.Row = nm_rng.Row _
And result.Column = nm_rng.Column Then
MsgBox "Named range """ & nm.Name & """ isn't used!"
End If
nm_rng.ShowDependents True
Set nm_rng = Nothing
Set result = Nothing
End Sub
Sub test_all_names()
Dim nm As Name
Dim sht As Worksheet
For Each nm In ThisWorkbook.Names
test_for_dependents nm
Next nm
For Each sht In ThisWorkbook.Sheets
For Each nm In sht.Names
test_for_dependents nm
Next nm
Next sht
Set nm = Nothing
Set sht = Nothing
End Sub
The following NamesInCells macro reports the number of formula cells referencing each defined name (named range) in the active workbook. Results are in columns A:D (Scope, Name, RefersTo, Cells) starting at row 1 of the workbook's NamesInCells worksheet. If that worksheet does not exist, it will be added after the last sheet.
For each Name that is Visible (not hidden), the macro uses Private Function Formula_Errors to determine how many formula cells have errors before and after the Name's RefersTo property is made invalid. The before and after difference is the number of cells referencing that Name in a formula. However, if a Name is used in a cell formula that produced an error before, the after result will be the same for that cell. This issue is resolved by Private Function Prior_Errors which determines if the Name appears in an error cell's formula before the Name was made invalid. The InStr method used by Prior_Errors is imperfect, but only for formulas that had errors before initiating the macro (hopefully few). Also, a Name with workbook scope and a duplicate Name with sheet scope might be extraneously counted if they are in separate formulas that had initial errors.
This macro was inspired by Doug Glancy's answer above: https://stackoverflow.com/a/26691025/10172433
Public Sub NamesInCells()
Const myName As String = "NamesInCells"
Dim WB As Workbook, oName As Name, A() As Variant, vCells As Variant
Dim sScope As String, sName As String, sRefersTo As String
Dim nRows As Long, nR As Long, nBase As Long, n As Integer
Set WB = ActiveWorkbook
nRows = WB.Names.Count
If nRows = 0 Then
MsgBox "There are no defined names in the active workbook", _
vbInformation, myName
Exit Sub
End If
nRows = nRows + 1
ReDim A(1 To 4, 1 To nRows)
nR = 1
A(1, 1) = "Scope"
A(2, 1) = "Name"
A(3, 1) = "RefersTo"
A(4, 1) = "Cells"
nBase = Formula_Errors(WB)
For Each oName In WB.Names
With oName
If .Visible Then 'skip hidden names
n = InStrRev(.Name, "!")
If n = 0 Then
sScope = "Workbook"
sName = .Name
ElseIf n > 1 Then
sScope = Left(.Name, (n - 1))
sName = Mid(.Name, (n + 1))
End If
sRefersTo = .RefersTo
If Left(sScope, 1) = "'" Then _
sScope = Mid(sScope, 2, (Len(sScope) - 2))
.RefersTo = "#REF!"
vCells = Formula_Errors(WB) - nBase
.RefersTo = sRefersTo
vCells = vCells + Prior_Errors(WB, .Name)
nR = nR + 1
A(1, nR) = sScope
A(2, nR) = sName
A(3, nR) = "'" & sRefersTo
A(4, nR) = vCells
End If
End With
Next oName
If nR < 2 Then
MsgBox "There are no visible defined names in the active workbook", _
vbInformation, myName
Exit Sub
ElseIf nR < nRows Then
ReDim Preserve A(1 To 4, 1 To nR)
End If
On Error Resume Next
With WB
.Worksheets(myName).Activate
If Err = 0 Then
Range("A:D").Clear
Else
.Worksheets.Add After:=.Sheets(.Sheets.Count)
ActiveSheet.Name = myName
End If
End With
On Error GoTo 0
Range("A1").Select
Selection.Resize(nR, 4).Value = Application.Transpose(A)
End Sub
Private Function Formula_Errors(WB As Workbook) As Long
Dim WS As Worksheet, R As Range, nCount As Long
For Each WS In WB.Worksheets
On Error Resume Next
Set R = WS.Cells.SpecialCells(xlCellTypeFormulas, xlErrors)
If Err = 0 Then nCount = nCount + R.Count
On Error GoTo 0
Next WS
Formula_Errors = nCount
End Function
Private Function Prior_Errors(WB As Workbook, Name As String) As Long
Dim WS As Worksheet, R As Range, rCell As Range, nCount As Long
Dim sWS As String, sN As String, sF As String, n As Integer
n = InStrRev(Name, "!")
If n > 1 Then
sN = Mid(Name, (n + 1))
sWS = Left(Name, (n - 1))
If Left(sWS, 1) = "'" Then sWS = Mid(sWS, 2, (Len(sWS) - 2))
End If
For Each WS In WB.Worksheets
On Error Resume Next
Set R = WS.Cells.SpecialCells(xlCellTypeFormulas, xlErrors)
If Err = 0 Then
For Each rCell In R
sF = rCell.Formula
If WS.Name = sWS Then
If InStr(1, sF, sN, vbBinaryCompare) > 0 Then
nCount = nCount + 1
End If
ElseIf InStr(1, sF, Name, vbBinaryCompare) > 0 Then
nCount = nCount + 1
End If
Next rCell
End If
On Error GoTo 0
Next WS
Prior_Errors = nCount
End Function
I'm currently "trying" to setup a grid in Excel where
the user inputs a reference (e.g. HP1 or HP234) and,
I can automatically detect the cell it was entered into and the numeric value in the cell (e.g. HP1 = 1, HP234 = 234).
I have started to play with the code below. In the section msgbox("work") - I'm using just to test code around it. Here I want to return the numeric value in the cell and the cell location so I can put them onto a report.
Any help would be greatly appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim rngTarget As Range
Set rngTarget = Range("a1:a100")
If Not Intersect(Target, Range("A1:A100")) Is Nothing Then
For Each rng In rngTarget
If InStr(1, prNg, "H") > 0 And InStr(1, rngEachValue, "P") = 0 Then
MsgBox ("works")
End If
Next
End If
End Sub
I found this a nice question so put some work into the answer. I think this will do just what you want! It even works with decimal and thousand separators.
I do admit the NumericalValue function could be created in a different way as well (find the first and the last number and take that mid part of the string.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim rngTarget As Range
Dim varValue As Variant
Set rngTarget = Range("a1:a100")
If Not Intersect(Target, rngTarget) Is Nothing Then
For Each rng In rngTarget
'only check cells that contain an H and a P
If InStr(1, rng, "H") > 0 And InStr(1, rng, "P") > 0 Then
'find the numerical value if any (Empty if not found)
varValue = NumericalValue(rng.Value2)
If Not IsEmpty(varValue) Then
MsgBox "hurray the value of cell " & rng.AddressLocal & " is " & varValue
End If
End If
Next
End If
End Sub
'return the first numerical value found in the cell
Private Function NumericalValue(ByVal strValue As String) As Variant
Dim intChar As Integer
Dim booNumberFound As Boolean
Dim intDecimal As Integer
booNumberFound = False
NumericalValue = Val(strValue)
For intChar = 1 To Len(strValue) Step 1
'if a number found then grow the total numerical value with it
If IsNumeric(Mid(strValue, intChar, 1)) Then
NumericalValue = NumericalValue * IIf(intDecimal = 0, 10, 1) + _
Val(Mid(strValue, intChar, 1)) * 10 ^ -intDecimal
If intDecimal > 0 Then
intDecimal = intDecimal + 1
End If
booNumberFound = True
'if the decimal separator is found then set the decimal switch
ElseIf intDecimal = 0 And booNumberFound = True And Mid(strValue, intChar, 1) = Application.DecimalSeparator Then
intDecimal = 1
'skip the thousand separator to find more numbers
ElseIf booNumberFound = True And Mid(strValue, intChar, 1) = Application.ThousandsSeparator Then
ElseIf booNumberFound = True Then
Exit For
End If
Next intChar
End Function
you're most of the way there, try the below:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim rngTarget As Range
Dim sText As String
Set rngTarget = Range("a1:a100")
If Not Intersect(Target, Range("A1:A100")) Is Nothing Then
For Each rng In rngTarget
If InStr(1, rng.Text, "H") > 0 And InStr(1, rng.Text, "P") > 0 Then
sText = rng.Text
sText = Replace(sText, "H", "")
sText = Replace(sText, "P", "")
Debug.Print rng.Address & " = " & Val(sText)
End If
Next
End If
End Sub