I have a function that selects a range based on a whole bunch of criteria from Sheet2. I'm trying to copy this range and to show/paste on Sheet1 or have it show in a message box.
Public Function findrulepos(target As Range, destination As Range) As String
Dim ruleStart As Range
Dim ruleEnd, ruleEnd2 As String
Dim Xcell, PasteRangeIndexCell As Range
Dim RuleRange As Range
Dim LastCell As Range
Dim FirstCell, IndexCell As Range
Dim WholeRule As Range
MaxRule = 100000
MaxRow = 100000
Sheets("ResRules").Select
For i = 2 To MaxRow
If CStr(ThisWorkbook.Sheets("ResRules").Range("A" & i).Value) = CStr(target.Value) Then
Set ruleStart = ThisWorkbook.Sheets("ResRules").Range("B" & i) '.offset(0, 1)
Exit For
End If
Next i
'MsgBox (ruleStart.address)
Set FirstCell = ruleStart.offset(1, -1)
Set IndexCell = FirstCell
Do Until IndexCell.Value <> "" Or IndexCell.Row >= MaxRow
Set IndexCell = IndexCell.offset(1, 0)
Loop
If IndexCell.Value <> "" Then
Set LastCell = IndexCell.offset(-1, 1)
MsgBox (LastCell.Value)
Else
Set LastCell = Nothing
End If
Set WholeRule = ThisWorkbook.Sheets("ResRules").Range("" & ruleStart.address & ":" & LastCell.address & "")
End Function
This is the whole code to give me the range I require
I have added a watch and can see I am getting the correct range i.e. $B$3:$B$6 but cant copy this range to Sheet 1
If your function is being called from a worksheet cell, then copy/paste won't work since that type of function can only return a value to the cell in which it resides. You need a function called from a Sub.
Use the following to get the address:
Sheet1.Range("A1").value = WholeRule.address
or, if you want to copy the actual content in the cells:
WholeRule.copy Sheet1.Range("A1")
thanks guys
worked it out
changed it to a Sub then
Public Sub ReturnRuleButton()
Call findrulepos(ThisWorkbook.Sheets("Main").Cells(2, 5), ThisWorkbook.Sheets("Main").Cells(2, 6))
End Sub
Related
I want to find "Ext" and "/" in a column of data and delete all the text after and including those characters
If it doesn't find those characters in my data then exit the sub
I can do them separately but I definitely over complicated it, there must be an easier way
The data column will also have blanks in so I have to avoid blank cells and check the whole range of data
Code
Sub DeleteAfterText()
Dim rngFoundCell As Range
Set rngFoundCell = Sheets("User Load").Range("E1:E3000").Find(What:="Ext")
'This is checking to see if the range contains EXT, if not it exits the sub'
If rngFoundCell Is Nothing Then 'If no cell in the range has an ' then exist sub
Exit Sub
Else
Worksheets("User Load").Range("E1000").Select 'Start from bottom'
Selection.End(xlUp).Select 'This selects the bottom to the top'
Do Until ActiveCell.Value = "Phone Number" 'This does the change until it reaches the header name'
If ActiveCell.Value = "" Then 'If the cell is blank it skips it as there is no action after the then'
Else
ActiveCell = Split(ActiveCell.Value, "Ext")(0)
'ActiveCell = Split(ActiveCell.Value, "/")(0)
End If
ActiveCell.Offset(-1, 0).Select
Loop
End If
End Sub
Sub DeleteAfterText2()
Dim rngFoundCell As Range
Set rngFoundCell = Sheets("User Load").Range("E1:E3000").Find(What:="/")
'This is checking to see if the range contains EXT, if not it exits the sub'
If rngFoundCell Is Nothing Then 'If no cell in the range has an ' then exist sub
Exit Sub
Else
Worksheets("User Load").Range("E1000").Select 'Start from bottom'
Selection.End(xlUp).Select 'This selects the bottom to the top'
Do Until ActiveCell.Value = "Phone Number" 'This does the change until it reaches the header name'
If ActiveCell.Value = "" Then 'If the cell is blank it skips it as there is no action after the then'
Else
ActiveCell = Split(ActiveCell.Value, "/")(0)
End If
ActiveCell.Offset(-1, 0).Select
Loop
End If
End Sub
This code should work. It is simple to read and easy to understand.
Option Explicit
'The calling Sub
Sub main()
DeleteTextFromColumn ActiveSheet.Range("E1:E3000")
End Sub
Sub DeleteTextFromColumn(ByRef inRange As Range)
Dim cCell As Range
Dim intPos1 As Integer
Dim intPos2 As Integer
Dim strTemp As String
Dim strOut As String
'You can specify which column if more than one column is provided to the
' subroutine. Ex: Range("E1:F3000")
For Each cCell In inRange.Columns(1).Cells
strTemp = cCell.Value
'gets the position of "ext" (case insensitive)
intPos1 = InStr(LCase(strTemp), "ext")
'gets the position of "/"
intPos2 = InStr(strTemp, "/")
strOut = strTemp
If intPos1 > 1 Then
strOut = Mid(strTemp, 1, intPos1 - 1)
ElseIf intPos2 > 1 Then
strOut = Mid(strTemp, 1, intPos2 - 1)
End If
'Outputs the results
cCell.Value = strOut
Next
End Sub
It's best to break out repeated code into a sub which has parameters for the variable parts of the operation.
You can do something like this:
Sub Tester()
Dim theRange As Range
Set theRange = Sheets("User Load").Range("E1:E3000")
RemoveTextAfter theRange, "Ext"
RemoveTextAfter theRange, "/"
End Sub
Sub RemoveTextAfter(rng As Range, findWhat As String)
Dim f As Range
If Len(findWhat) = 0 Then Exit Sub
Set f = rng.Find(What:="Ext", lookat:=xlPart)
Do While Not f Is Nothing
f.Value = Split(f.Value, findWhat)(0)
Set f = rng.Find(What:="Ext", lookat:=xlPart)
Loop
End Sub
I'm going to give you two answers for the price of one. :)
At its root, the basic logic you need to figure out if a substring exists in a given string is a standard part of VBA in the InStr function. Using this, you can break out your logic to check a cell's value and (conditionally) delete the remainder of the string into a function like this:
Private Function DeleteTextAfter(ByVal contents As String, _
ByVal token As String) As String
'--- searches the given string contents and if it finds the given token
' it deletes the token and all following characters
DeleteTextAfter = contents
Dim pos1 As Long
pos1 = InStr(1, contents, token, vbTextCompare)
If pos1 > 0 Then
DeleteTextAfter = Left(contents, pos1 - 1)
End If
End Function
Notice here that using the function created above, we don't need to use Range.Find at all.
Once you have that, your top-level logic consists of setting up the range to search. In all of my code, I explicitly create objects to reference the workbook and worksheet so that I can keep things straight. In a simple example like this, it may seem like overkill, but the habit comes in handy when your code gets more involved. So I set up the range like this
Dim thisWB As Workbook
Dim userLoadWS As Worksheet
Set thisWB = ThisWorkbook
Set userLoadWS = thisWB.Sheets("User Load")
Dim searchRange As Range
Set searchRange = userLoadWS.Range("E1:E3000")
Now the loop just goes through each cell and gets a (potentially) updated value.
Dim cell As Variant
For Each cell In searchRange
If Not cell.value = vbNullString Then
Debug.Print cell.Address & " = " & cell.value
cell.value = DeleteTextAfter(cell.value, "Ext")
cell.value = DeleteTextAfter(cell.value, "/")
End If
Next cell
So your whole solution looks like this:
Option Explicit
Public Sub TestDirectlyFromRange()
Dim thisWB As Workbook
Dim userLoadWS As Worksheet
Set thisWB = ThisWorkbook
Set userLoadWS = thisWB.Sheets("User Load")
Dim searchRange As Range
Set searchRange = userLoadWS.Range("E1:E3000")
Dim cell As Variant
For Each cell In searchRange
If Not cell.value = vbNullString Then
Debug.Print cell.Address & " = " & cell.value
cell.value = DeleteTextAfter(cell.value, "Ext")
cell.value = DeleteTextAfter(cell.value, "/")
End If
Next cell
End Sub
Private Function DeleteTextAfter(ByVal contents As String, _
ByVal token As String) As String
'--- searches the given string contents and if it finds the given token
' it deletes the token and all following characters
DeleteTextAfter = contents
Dim pos1 As Long
pos1 = InStr(1, contents, token, vbTextCompare)
If pos1 > 0 Then
DeleteTextAfter = Left(contents, pos1 - 1)
End If
End Function
But wait, there's more!!
You're iterating over 3,000 rows of data. That can get to be slow if all those rows are filled or if you increase the number of rows to search. To speed up the search, the answer is to copy the data in the range to a memory-based array first, modify any of the data, then copy the results back. This example uses the same Function DeleteTextAfter as above and is much quicker. Use whichever one fits your situation best.
Public Sub TestRangeInArray()
Dim thisWB As Workbook
Dim userLoadWS As Worksheet
Set thisWB = ThisWorkbook
Set userLoadWS = thisWB.Sheets("User Load")
'--- create the range and copy into a memory array
Dim searchRange As Range
Dim searchData As Variant
Set searchRange = userLoadWS.Range("E1:E3000")
searchData = searchRange.value
Dim i As Long
For i = LBound(searchData, 1) To UBound(searchData, 1)
If Not searchData(i, 1) = vbNullString Then
searchData(i, 1) = DeleteTextAfter(searchData(i, 1), "Ext")
searchData(i, 1) = DeleteTextAfter(searchData(i, 1), "/")
End If
Next i
'--- now copy the modified array back to the worksheet range
searchRange.value = searchData
End Sub
I'm trying to write something up that will search a specific range for specific numbers.
EX:
Dim cell As Range
For Each cell In Range("E5:E112")
If InStr(cell.Value, "260") > 0 Then
DO THIS
ElseIf InStr(cell.Value, "154") > 0 Then
DO THIS
etc...
I used instr since the cell will have things like "word 1 word 2 260 word 3."
For every match it finds within that range, I want to put a certain value into the same row in a different column.
Suggestions? Thanks in advance!
Try This:
Sub testing()
Dim cell As Range
For Each cell In Range("E5:E112")
If InStr(cell.Value, "260") > 0 Then
cell.Offset(0, 2).Value = "Found 260"
ElseIf InStr(cell.Value, "154") > 0 Then
cell.Offset(0, 2).Value = "Found 154"
End If
Next
End Sub
create an array of the items you want to look up then loop that with a built in lookup function.
Then use the row number returned to find the value you want. It will be quicker
Dim lkupArr()
lkupArr = Array(260, 154)
Dim i As Long
For i = LBound(lkupArr) To UBound(lkupArr)
Dim lkuprow As Long
lkuprow = 0
On Error Resume Next
lkuprow = Application.WorksheetFunction.Match("*" & lkupArr(i) & "*", ActiveSheet.Range("E:E"), 0)
On Error GoTo 0
If lkuprow > 0 Then
MsgBox lkupArr(i) & " found on row " & lkuprow & "."
'Then just use the return to return the value from the column you want
'The following returns the value in column F on the same row.
Dim ret
ret = ActiveSheet.Cells(lkuprow, "F").Value
Debug.Print ret
End If
Next i
Maybe not the most elegant solution, however does not make extensive use of the spreadsheet, so performance wise (if you have a lot of data to process), should be better than other solutions so far.
Function SearchAndFind()
Dim wb As Workbook
Dim ws As Worksheet
Dim rngValues As Range
Dim arrRng As Variant, arrFind As Variant
Dim i As Long, j As Long, newColOffset As Long
'Adjust as needed
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
Set rngValues = ws.Range("E5:E112")
arrRng = rngValues
arrFind = Array("260", "154")
newColOffset = 2
For i = LBound(arrRng) To UBound(arrRng) 'loop through the given range, first column only
For j = LBound(arrFind) To UBound(arrFind) 'loop through items to find
If InStr(arrRng(i, 1), arrFind(j)) > 0 Then 'found the value
'Return the values
rngValues.Cells(1, 1).Offset(i - 1, newColOffset).Value = arrRng(i, 1)
Exit For
End If
Next j
Next i
End Function
I have growing data files and in a certain column is not fill out. I have the code to fill the data, though I want to make a button to call userform for user to fill in the range so that the code works within the range provided by the user(since data is adjusted by the user itself). The code to fill the blank cell is;
Sub fillblank()
Dim range As Range
Dim cell As Range
Dim value As String
Set range = Sheets("Sheet1").Range("E4:E15")
For Each cell In range
If Trim(cell.Value) <> "" Then
value = cell.Value
Else
cell.Value = value
End if
Next cell
End Sub
I would like the user to enter the range (E4:E15) in userform. How to do the userform if its dependent only range? Thanks stackoverflow.com.
Put a text box in userform and name it txtRng. Then declare a variable named MyRng as String. Assign that text box value to MyRng variable and use this variable as argument of range like...
Set range = Sheets("Sheet1").Range(MyRng)
So, full code will be like as below
Sub fillblank()
Dim range As range
Dim cell As range
Dim value As String
Dim MyRng As String
MyRng = UserForm1.txtRng 'Use your form name here
Set range = Sheets("Sheet1").range(MyRng)
For Each cell In range
If Trim(cell.value) <> "" Then
value = cell.value
Else
cell.value = value
End If
Next cell
End Sub
I also suggest you to not use range, value as variable because some of these reserve keyword. It may cause misbehave of output.
You could use the InputBox() method and have the user select a range:
Sub fillblank()
Dim myRange As Range
Dim cell As Range
Dim myValue As String
Set myRange = Application.InputBox( prompt:="Select a range", Type:=8)
For Each cell In myRange
If Trim(cell.Value) <> "" Then
myValue = cell.Value
Else
cell.Value = myValue
End if
Next
End Sub
or you could add a RefEdit control to your userform and process it
Sub fillblank()
Dim cell As range
Dim myValue As String
For Each cell In range(Me.RefEdit1.Text)
If Trim(cell.value) <> "" Then
myValue = cell.value
Else
cell.value = myValue
End If
Next cell
End Sub
In this case, since the user could input an invalid range, you may want to add a validation function (named GetRange in my following example)
Sub fillblank()
Dim myRange As range
If Not GetRange(Me.RefEdit1.Text, myRange) Then
MsgBox "Select a valid range "
Me.RefEdit1.SetFocus
Exit Sub
End If
Dim cell As range
Dim myValue As String
For Each cell In myRange
If Trim(cell.value) <> "" Then
myValue = cell.value
Else
cell.value = myValue
End If
Next cell
End Sub
Function GetRange(RefEditText As String, myRange As range) As Boolean
On Error Resume Next
Set myRange = range(RefEditText)
On Error GoTo 0
GetRange = Not myRange Is Nothing
End Function
finally, here is an alternative method (no loops) to fill blank cells as you're wanting to do:
Sub fillblank()
With range(Me.RefEdit1.Text).SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[-1]C"
.value = .value
End With
End Sub
To ask the user for a range you could use InputBox(Type:=8)
The code bellow will accept only one column
If an entire column is selected (A:A) or multiple columns it adjusts to the total rows in UsedRange and first column in selection
Option Explicit
Public Sub FillBlanks()
Dim selectedCol As Range, itm As Range, lr As Long
On Error Resume Next
Set selectedCol = Application.InputBox(Prompt:="Select column:", Type:=8)
On Error GoTo 0
If selectedCol Is Nothing Then Exit Sub 'User cancelled selection
With selectedCol
.Parent.Activate
lr = .Parent.UsedRange.Rows.Count
If .Columns.Count > 1 Then Set selectedCol = .Resize(.Rows.Count, 1)
If .Rows.Count < 2 Or .Rows.Count > lr Then Set selectedCol = .Resize(lr - .Row + 1, 1)
selectedCol.Select
End With
For Each itm In selectedCol
If Len(Trim$(itm)) = 0 And itm.Row > 1 Then itm.Value2 = itm.Offset(-1).Value2
Next
End Sub
Note: It's not recommended to name your variables with special VBA keywords
Dim range As Range - Range is the most important object in Excel
Dim value As String - Value is the most important property of the Range object
I believe I'm looking for the inverse of the Range Function. I have a named range in my worksheet and in an event macro. I'm interested in getting the range definition string back, such as "A1:A12".
Here is the code I'm working on:
Private Sub UserForm_Initialize()
Dim MyData As Range
Dim r As Long
With Me.ListBox1
.RowSource = ""
Set MyData = Worksheets("Sheet1").Range("A2:D100") 'Adjust the range accordingly
.List = MyData.Cells.Value
For r = .ListCount - 1 To 0 Step -1
If .List(r, 3) = "" Then
.RemoveItem r
End If
Next r
End With
End Sub
I'd rather use the name of the Range in the "Set MyData =" statement above instead of hard-coding the range in the event macro.
If you simply want the address of a Range, use
Dim MyRange as Range
Set MyRange = Worksheets("Sheet1").Range("A2:D100")
' Here do what you want
Msgbox MyRange.Address
.Address will return the "A2:D100" address
https://msdn.microsoft.com/fr-fr/library/office/ff837625.aspx
How to find location of last cell from defined Range? Cell does not have to contain any data but must be most right and most down located cell from certain Range.
Set rngOrigin = wksOrigin.Cells(IntFirstRow, IntFirstColumn).CurrentRegion
I wish to receive
Cells(i,j)
Perhaps this is what you want:
Dim rngLastCell As Range
Set rngLastCell = rngOrigin(rngOrigin.Count)
maybe you're after this:
'absolute indexes from cell A1
With rngOrigin
i = .Rows(.Rows.count).row
j = .Columns(.Columns.count).Column
End With
'relative indexes from rngOrigin upleftmost cell
With rngOrigin
i = .Rows(.Rows.count).row - .Rows(1).row + 1
j = .Columns(.Columns.count).Column - .Columns(1).Column + 1
End With
I handled it in below code but your remarks were helpful. Thank you.
intLastRow = rngOrigin.Cells(1, 1).Row + rngOrigin.Rows.Count - 1
intLastCol = rngOrigin.Cells(1, 1).Column + rngOrigin.Columns.Count - 1
The answers given by others mostly work, but not if the region is a union of non-contiguous cells. Here is a version that works consistently for single and multi-area regions, contiguous and non-contiguous.
Function LastCellOfRange(rng As Excel.Range) As Excel.Range
Dim area As Excel.Range
Dim rowNum As Long
Dim maxRow As Long
Dim colNum As Long
Dim maxCol As Long
Dim areaIdx As Integer
Set LastCellOfRange = Nothing
maxRow = 0
maxCol = 0
For areaIdx = 1 To rng.Areas.Count
Set area = rng.Areas(areaIdx)
rowNum = area.Cells(area.Cells.Count).row
If (rowNum > maxRow) Then
maxRow = rowNum
End If
colNum = area.Cells(area.Cells.Count).Column
If (colNum > maxCol) Then
maxCol = colNum
End If
Next areaIdx
Set LastCellOfRange = rng.Worksheet.Cells(maxRow, maxCol)
Set area = Nothing
End Function
Use this to code find the last cell in a given range
Sub GetLastCellFromRange()
Dim rng As Range
Set rng = Range("$C$10:$E$20")
'Set rng = Range(Selection.Address) ' Use this line to select the range in worksheet
MsgBox "Last Cell of given range is : " & rng.Cells(rng.Rows.Count, rng.Columns.Count).Address
End Sub
I hope it will help you
you could try the following but it relies upon cells always being populated
rngOrigin.End(xlDown).End(xlRight)
or you could use the CurrentRegion and count the rows and columns and use Offset
Alternatively, you could use this construct which works even with ranges based on entire rows or entire columns.
Sub Test()
Dim rngOrigin As Excel.Range
Set rngOrigin = Range("$A$1:$D$6")
Dim rngLast As Excel.Range
Set rngLast = rngOrigin.Cells(rngOrigin.Cells.Count)
Debug.Print rngLast.Address
End Sub
Finally, for ranges with multiple areas you'll have to script against a range's Areas collection ...
Sub Test()
Dim rngOrigin As Excel.Range
Set rngOrigin = Range("$A$1:$D$6,$F$1:$G$6")
Debug.Print rngOrigin.Areas(1).Cells(rngOrigin.Areas(1).Cells.Count).Address
Debug.Print rngOrigin.Areas(2).Cells(rngOrigin.Areas(2).Cells.Count).Address
End Sub
Many answers here will work as long as the given range is continuous. This is what I would use for a range that you are absolutely sure is going to be continuous:
Sub test()
Dim myRng As Range, lastCell As Range
Set myRng = Range("A1:D4")
Set lastCell = myRng.Cells(myRng.Rows.Count, myRng.Columns.Count)
Debug.Print lastCell.Address 'returns $D$4
End Sub
For non-continuous, DB user10082797 gave a great solution, however their function fails when the ranges are positioned diagonal-up (for example, if you pass rng=A3:B4,C1:D2 in you will get D4 as the output which was not part of the original range.)
So the question becomes, what is the last cell in the range A3:B4,C1:D2? Is it B4 or D2? That's a decision for the programmer. Here is a function I wrote with the help of DB user10082797's function:
Function LastCellOfRange(rng As Range, Optional returnLastRow As Boolean = True) As Range
'returns the last cell in #rng.
'if #returnLastRow is TRUE, then the output will always be in the right most cell of the last row of #rng
'if #returnLastRow is FALSE, then the output will always be in the bottom most cell of the last column of #rng
'(#returnLastRow only matters for non-contiguous ranges under certain circumstances.)
'initialize variables
Dim area As Range, areaIdx As Long
Dim lastCellInArea As Range
'loop thru each area in the selection
For areaIdx = 1 To rng.Areas.Count
Set area = rng.Areas(areaIdx) 'get next area
Set lastCellInArea = area.Cells(area.Rows.Count, area.Columns.Count) 'get the last cell in the area
'if:
' the return is empty
' OR if the last row needs to be returned and this row is larger than the last area's
' OR if the last row needs to be returned and this row is the same as the last area's but has a larger column
' OR if the last column needs to be returned and this column is larger than the last area's
' OR if the last column needs to be returned and this column is the same as the last area's but has a larger row
'THEN:
' make this cell the return range
If LastCellOfRange Is Nothing Then
Set LastCellOfRange = lastCellInArea '(must be seperate from the other statment when its not set to anything)
ElseIf _
returnLastRow = True And lastCellInArea.Row > LastCellOfRange.Row _
Or returnLastRow = True And lastCellInArea.Row = LastCellOfRange.Row And lastCellInArea.Column > LastCellOfRange.Column _
Or returnLastRow = False And lastCellInArea.Column > LastCellOfRange.Column _
Or returnLastRow = False And lastCellInArea.Column = LastCellOfRange.Column And lastCellInArea.Row > LastCellOfRange.Row _
Then
Set LastCellOfRange = lastCellInArea
End If
Next areaIdx
End Function
You can use the function like this:
Sub test()
Dim myRng As Range
Set myRng = Range("A3:B4,C1:D2")
Debug.Print LastCellOfRange(myRng).Address 'returns $B$4
Debug.Print LastCellOfRange(myRng, False).Address 'returns $D$2
End Sub
In your case, since you want to find the cell to the most right and down in your wksOrigin (defined as Worksheet), you could use the SpecialCells(xlCellTypeLastCell) to get the last cell Row and Column.
i = wksOrigin.Cells.SpecialCells(xlCellTypeLastCell).Row ' <-- get last row number
j = wksOrigin.Cells.SpecialCells(xlCellTypeLastCell).Column ' <-- get last column number
If you want to debug your result, you can add:
MsgBox "Last row at " & i & ", last column at " & j
If you want the absolute last cell of a defined range, regardless of whether it has any content, here is a simple solution
Dim InputRng As Range 'define a range for the test'
Set InputRng = Range("$F$3:$F$15")
MsgBox InputRng(1).Address & ":" & InputRng(InputRng.Cells.Count).Address 'This would output the absolute address of defined range'