Scenario: Range is named "Dog" and the named range Dog refers to A1:D4. The active cell is in cell B3, which is within the named range.
Is it possible to get the name of the named range that the active cell is in? ie return the name "Dog"?
Perhaps something like the following, which tests the Intersection of the ActiveCell and each named range.
The On Error Resume Next...On Error GoTo 0 is necessary since Intersect will fail when the ActiveCell and the named range are on different sheets, or if n is not a named range but if it refers to a constant or formula, for example.
Sub test()
Dim n As Name
For Each n In ActiveWorkbook.Names
Dim rng As Range
Set rng = Nothing
On Error Resume Next
Set rng = Intersect(ActiveCell, n.RefersToRange)
On Error GoTo 0
If Not rng Is Nothing Then
Debug.Print n.Name
End If
Next
End Sub
This should be a more robust way...
Sub Test()
MsgBox NamesUsedBy(ActiveCell)
End Sub
Function NamesUsedBy(r As Range)
Dim s$, n
On Error Resume Next
For Each n In ThisWorkbook.Names
If Intersect(r, Evaluate(Mid(n, 2))).Row Then
If Err = 0 Then s = s & ", " & n.Name
End If
Err.Clear
Next
NamesUsedBy = Mid(s, 3)
End Function
There is probably a more elegant way of doing this, but this should work.
Sub test()
Dim currentrange As Range
Dim r As Variant
Set currentrange = ActiveCell
For Each r In ThisWorkbook.Names
If Not Application.Intersect(currentrange, Range(Right(r, InStr(1, r, "$")))) Is Nothing Then
Debug.Print r.Name
End If
Next r
End Sub
Related
Is there any quicker method than using a for loop to find the first instance of a formula in a cell?
For Each dc In .Worksheets("testWS").Range(searchRange)
If dc.hasFormula() = True Then
formulaRow = Split(dc.Address, "$")(2)
formula = dc.formula
Exit For
End If
Next
No loop needed - use Range.SpecialCells. Include error handling since there may be no cells with formulas.
On Error Resume Next
Dim formulaRng As Range
Set formulaRng = .Worksheets("testWS").Range(searchRange).SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not formulaRng Is Nothing Then
Debug.Print formulaRng.Cells(1).Row
Debug.Print formulaRng.Cells(1).Formula
End If
Function FindFirstFormulaRow(ByRef rng As Range) As Long
Dim arrFormulas As Variant
Set arrFormulas = rng.SpecialCells(xlCellTypeFormulas)
Set rng = arrFormulas
If Not rng Is Nothing Then
FindFirstFormulaRow = Split(rng.Cells(1).Address, "$")(2)
Set rng = rng.Cells(1)
End If
End Function`
i tried to use range("A1:I1").value to find multiple strings at the first row however it shows that error "mismatch". What have i done wrong here? Is there another way to do it?
Dim sht as worksheet
Set sht = ThisWorkbook.Sheets("Result")
If sht.range("A1:I1").value = " Voltage" and sht.range("A1:I1").value = " Time" ,<---------error 'mismatch' occurs here
call powerandtime
The problem here is that you are comparing an array of values against a single value. In case of such a small array you can make use of some Application.Methods. Another option would be to use Range.Find on the actual Range object. I'll demonstrate both below:
Application.Methods
Sub Test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Result")
Dim arr As Variant
With Application
arr = .Transpose(ws.Range("A1:I1").Value)
If .Count(.Match(Array("Voltage", "Time"), arr, 0)) = 2 Then
Call PowerAndTime
End If
End With
End Sub
What happens here is that .Match will return an array of two elements. It will either return an error value to the array if either "voltage" or "time" is not found, or it would return a numeric value when either one of them is found. Then .Count will count numeric values within that returned array, and only if the count would be 2, is when both values are present within your initial range.
Note: .Match needs a 1D-array, hence the .Transpose at the start.
Range.Find
Sub Test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Result")
Dim rng1 As Range, rng2 As Range
Set rng1 = ws.Range("A1:I1").Find("Voltage", lookat:=xlWhole)
Set rng2 = ws.Range("A1:I1").Find("Time", lookat:=xlWhole)
If Not rng1 Is Nothing And Not rng2 Is Nothing Then
Call PowerAndTime
End If
End Sub
So only when both "Voltage" and "Time" are found as xlWhole values within your specific range, it would continue to call PowerAndTime.
Sub testMatchBis()
Dim sh As Worksheet, rng As Range, voltPos As Long, timePos As Long
Dim rngBis As Range, arrBis as Variant
Set sh = ActiveSheet ' use please your sheet here
Set rng = sh.Range("A1:I1")
voltPos = IsMatch(rng, "Voltage")
timePos = IsMatch(rng, "Time")
If voltPos <> 0 And timePos <> 0 Then
Set rngBis = sh.Columns(voltPos)
Set rngBis = Union(rngBis, sh.Columns(timePos))
arrBis = rngBis.Value 'the both columns content will be input in an array
rngBis.Select 'both columns will be selected. Of course, you need to determine
'only part of the comumn keeping values (their last row) and limit the range
'Call call powerandtime 'You must know what this sub must do...
Else
MsgBox "(At least) one of your searched strings could not be found in the range..."
End If
End Sub
Private Function IsMatch(rng As Range, strS As String) As Long
On Error Resume Next
IsMatch = WorksheetFunction.Match(strS, rng, 0)
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
IsMatch = 0
End If
On Error GoTo 0
End Function
You could try:
Sub test()
Dim arrStrings As Variant
Dim i As Long, Counter As Long
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:I1")
Counter = 0
arrStrings = Split("Time,Electric", ",")
For i = LBound(arrStrings) To UBound(arrStrings)
If Not rng.Find(arrStrings(i), lookat:=xlWhole) Is Nothing Then
Counter = Counter + 1
GoTo NextIteration
End If
NextIteration:
Next i
If Counter = UBound(arrStrings) + 1 Then
Call PowerAndTime
End If
End Sub
I'm trying to delete rows in table if there is no value in a certain column.
I've used a code that deletes rows if there is one cell value missing, but I would like to delete rows if a cell does not contain a value in a certain column.
For example, if there is no value in Column G Row 5 then I want to delete the entire row.
Sub Test2()
Dim rng As Range
On Error Resume Next
Set rng = Range("Table3").SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
rng.Delete Shift:=xlUp
End If
End Sub
This deletes all rows with any type of missing cell value.
Two small changes:
Sub Test2()
Dim rng As Range
On Error Resume Next
Set rng = Range("G:G").SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
rng.EntireRow.Delete Shift:=xlShiftUp
End If
End Sub
EDIT:
If you want to work directly with the table, then consider iterating over the ListRows of the table in question, something like this:
Sub Test2()
Dim myTbl As ListObject
Set myTbl = Sheet1.ListObjects("table3") ' change sheet as necessary
Dim indx As Long
indx = myTbl.ListColumns("ColumnName").Index
Dim rngToDelete As Range
Dim myRw As ListRow
For Each myRw In myTbl.ListRows
If IsEmpty(myRw.Range(1, indx).Value) Then
If rngToDelete Is Nothing Then
Set rngToDelete = myRw.Range
Else
Set rngToDelete = Union(rngToDelete, myRw.Range)
End If
End If
Next myRw
If Not rngToDelete Is Nothing Then
rngToDelete.Delete Shift:=xlShiftUp
End If
End Sub
Note: Technically, it's xlShiftUp, not xlUp.
Have a range of cell with column headings as weeks In the range of cells I want to look for a number, say
1 if it finds a 1 then look at a column in said row for a variable, 2 or 4 whatever Now I want to put a triangle (can be copy and paste a cell) in the cell that has the "1" in it then skip over the number of week variable and add another triangle and keep doing this until the end of the range. Then skip down to the next row and do the same, until the end of the range.
Then change to the next page and do the same thing... through the whole workbook.
I think I have it done, don't know if it's the best way.
I get a error 91 at the end of the second loop, the first time the second loop ends it goes through the error code.
The second time the second loop ends it errors.
I don't understand it runs through once, but not twice.
Sub Add_Triangles2()
Dim Rng As Range
Dim OffNumber As Integer
Dim SetRange As Range
Dim OffsetRange As Range
Dim ws As Worksheet
Set SetRange = Sheets("Sheet1").Range("G25") ' Used to stop the second loop in range
Worksheets(1).Activate
Worksheets(1).Range("A1").Select ' Has item to be pasted (a triangle)
Selection.Copy
For Each ws In Worksheets
Worksheets(ws.Name).Activate
With Range("C4:G25")
Set Rng = .Find(1, LookIn:=xlValues)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rng.Activate
ActiveSheet.Paste
Do
OffNumber = Range("A" & ActiveCell.Row)
Set OffsetRange = SetRange.Offset(0, -OffNumber)
If Not ActiveCell.Address < OffsetRange.Address Then
Exit Do
Else
End If
ActiveCell.Offset(, OffNumber).Select
ActiveSheet.Paste
Loop While (ActiveCell.Address <= OffsetRange.Address)
On Error GoTo ErrorLine
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
End With
ErrorLine:
On Error GoTo 0
Application.EnableEvents = True
Next ws
Application.CutCopyMode = False
End Sub
I was not able to get an Error 91 using the data set I built from your explanation, maybe a screenshot of the layout could help recreate the issue.
However, I would do something like this, it will look at the value of each cell in the range C4:G25, and if it equals 1, it will paste the symbol stored in Cell A1.
Sub Add_Triangles2()
Dim Rng As Range
Dim rngSymbol As Range
Dim intFindNum As Integer
Dim ws As Worksheet
Set rngSymbol = Range("A1") 'Set range variable to hold address of symbol to be pasted
intFindNum = 1 'Used to hold number to find
Worksheets(1).Activate
For Each ws In Worksheets
Worksheets(ws.Name).Activate
For Each Rng In Range("C4:G25")
If Rng.Value = intFindNum Then
rngSymbol.Copy Rng
End If
Next Rng
Next ws
End Sub
I got it....
Sub Add_TriWorking()
Dim Rng As Range
Dim rngSymbol As Range
Dim intFindNum As Integer
Dim ws As Worksheet
Dim OffNumber As Integer
Dim SetRange As Range
Dim OffsetRange As Range
Set SetRange = Sheets("Sheet1").Range("G25") ' Used to stop the second loop in range
Set rngSymbol = Range("A1") 'Set range variable to hold address of symbol to be pasted
intFindNum = 1 'Used to hold number to find
Worksheets(1).Activate
For Each ws In Worksheets
Worksheets(ws.Name).Activate
For Each Rng In Range("C4:G25")
If Rng.Value = intFindNum Then
rngSymbol.Copy Rng
Rng.Activate
ActiveCell.Copy
Do
OffNumber = Range("A" & ActiveCell.Row)
Set OffsetRange = SetRange.Offset(0, -OffNumber)
If Not ActiveCell.Address < OffsetRange.Address Then
Exit Do
Else
End If
ActiveCell.Offset(, OffNumber).Select
ActiveSheet.Paste
Loop While (ActiveCell.Address <= OffsetRange.Address)
On Error GoTo ErrorLine
End If
Next Rng
ErrorLine:
On Error GoTo 0
Application.EnableEvents = True
Next ws
Application.CutCopyMode = False
End Sub
I am trying to write code that will loop through all cells in a range. Eventually I want to do something more complicated, but since I was having trouble I decided to create some short test programs. The first example works fine but the second (with a named range) doesn't (gives a "Method Range of Object_Global Failed" error message). Any ideas as to what I'm doing wrong? I'd really like to do this with a named range... Thanks!
Works:
Sub foreachtest()
Dim c As Range
For Each c In Range("A1:A3")
MsgBox (c.Address)
Next
End Sub
Doesn't work:
Sub foreachtest2()
Dim c As Range
Dim Rng As Range
Set Rng = Range("A1:A3")
For Each c In Range("Rng")
MsgBox (c.Address)
Next
End Sub
Set Rng =Range("A1:A3") is creating a range object, not a named range. This should work
Sub foreachtest2()
Dim c As Range
Dim Rng As Range
Set Rng = Range("A1:A3")
For Each c In rng
MsgBox (c.Address)
Next
End Sub
If you want to create a Named Range called Rng then
Range("A1:A3).Name="Rng"
will create it or you can create and loop it like thsi
Dim c As Range
Range("a1:a3").Name = "rng"
For Each c In Names("rng").RefersToRange
MsgBox c.Address
Next c
To adjust your second code, you need to recognize that your range rng is now a variable representing a range and treat it as such:
Sub foreachtest2()
Dim c As Range
Dim Rng As Range
Set Rng = Range("A1:A3")
For Each c In rng
MsgBox (c.Address)
Next
End Sub
Warning: most of the time, your code will be faster if you can avoid looping through the range.
Try this, instead:
Sub foreachtest2()
Dim c As Range
Range("A1:A3").Name = "Rng"
For Each c In Range("Rng")
MsgBox (c.Address)
Next
End Sub