VBA - Using Current Selection As Range Object - excel

I have this function below which does the following:
Takes two parameters (Header Name, Function Needed).
The Header Name parameter is used to find the heading and subsequently to identify the range of that column up until the last row.
The Function Needed parameter is used to switch in the select statement for any additional steps needed.
At the end of most of the statements, I do a Range.Select then I exit my function with a selected range.
Here is the code:
Function find_Header(header As String, fType As String)
Dim aCell As Range, rng As Range
Dim col As Long, lRow As Long
Dim colName As String
With ActiveSheet
Set aCell = .Range("B2:J2").Find(What:=header, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
'If Found
If Not aCell Is Nothing Then
col = aCell.Column
colName = Split(.Cells(, col).Address, "$")(1)
lRow = Range(colName & .Rows.count).End(xlUp).Row + 1
Set myCol = Range(colName & "2")
Select Case fType
Case "Copy"
'This is your range
Set rng = Range(myCol.Address & ":" & colName & lRow).Offset(1, 0)
rng.Select
End Select
'If not found
Else
MsgBox "Column Not Found"
End If
End With
End Function
As I am trying to clean up my code, I have come across a section where I have specifically hard coded ranges and I am trying to make use of my function instead, however, I am now at a point where I am unable to make use of this function correctly as I cannot "pass" the range back to the sub and I cannot seem to make the selection the range object needed for the sub.
Here is what is in the sub:
Sub Copy_Failed()
Dim xRg As Range, xCell As Range
Dim i As Long, J As Long, count As Long
Dim fType As String, colName As String
Dim y As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
myarray = Array("Defect", "System", "Script")
myEnv = Array("SIT", "UAT")
myDefects = Array("New", "Existing")
i = Worksheets("Run Results").UsedRange.Rows.count
J = Worksheets("Failed").UsedRange.Rows.count
Set y = Workbooks("Template.xlsm")
Set ws1 = y.Sheets("Failed")
Set ws2 = y.Sheets("Run Results")
count = 3
If J = 1 Then
If Application.WorksheetFunction.CountA(ws1.UsedRange) = 0 Then J = 0
End If
ws2.Activate
fType = "Copy"
colName = "Status"
Call find_Header(colName, fType)
End Sub
Before I used the function, the code looked like this:
lngLastRow = Cells(Rows.count, "B").End(xlUp).Row
Set xRg = ws2.Range("E3:E" & lngLastRow & i)
Now these 2 lines are performed in the function, so I don't need it in the sub. I have tried the following:
Set rngMyRange = Selection
Set rngMyRange = ActiveSheet.Range(Selection.Address)
Set xRg = ws2.Range(rngMyRange & i)
But I get the error:
Type mismatch
So I am thinking this:
Select the range in the function then use it in the sub - but how?
Figure out how to pass the actual range object from my function to the sub
Although the second option would require some extra changes in my code, I would think this is the better option to go with.

Ok, so here is an illustration just so you can see what I mean. If you put "one" somewhere in B2:J2 it will select the range. I am only using Select here so that you can see the range it identifies. (Disclaimer: I don't fully understand what you are doing, and not sure you need all this code to achieve what you want.)
The Function now returns a range variable, and is assigned to r. Run the procedure x.
Sub x()
Dim r As Range
Set r = Range("a1", find_Header("one", "Copy"))
r.Select
End Sub
Function find_Header(header As String, fType As String) As Range
Dim aCell As Range, rng As Range
Dim col As Long, lRow As Long
Dim colName As String
With ActiveSheet
Set aCell = .Range("B2:J2").Find(What:=header, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
'If Found
If Not aCell Is Nothing Then
col = aCell.Column
colName = Split(.Cells(, col).Address, "$")(1)
lRow = Range(colName & .Rows.Count).End(xlUp).Row + 1
Set myCol = Range(colName & "2")
Select Case fType
Case "Copy"
'This is your range
Set find_Header = Range(myCol.Address & ":" & colName & lRow).Offset(1, 0)
End Select
'If not found
Else
Set find_Header = Nothing
End If
End With
End Function

Related

Function returns temporary sheet

is this possible to create a function that returns temporary sheet?
Let's say I have got Sub as follow
Sub My_Sub()
Dim harm As Worksheet
Set harm = Sheets("my_sheet")
Dim lastRow As Long, arr
lastRow = harm.Range("A" & harm.Rows.Count).End(xlUp).Row
arr = harm.Range("T2:V" & lastRow).Value
MsgBox arr(2,5)+1
End Sub
Right now I'm working on harm = Sheets("my_sheet") and it loads whole sheet. Now I want to select part of that sheet and do the same operations so I wanted to write a function that will create temporary sheet, return it so in My_Sub I would have Set harm = ReturnSheet().
Is it possible? I want to load pseudo sheet from function, so I don't need to change anything in My_Sub (I mean those Ranges with column letter indexes).
Function ReturnSheet() As Worksheet
Dim Rng As Range
Dim lastRow As Long
Dim lastCol As Long
Set Rng = Selection
lastRow = Selection.Rows.Count
lastCol = Selection.Columns.Count
ReturnSheet.Range("A2").Resize(lastRow, lastCol).Value = Rng
End Function
Right now I'm getting Object variable or with block variable not set at ReturnSheet.Range("A2").Resize(lastRow, lastCol).Value = Rng
Try using the next Function. It returns a range meaning the selected cells without their first row:
Function ReturnRange(Optional boolAllRange As Boolean = False) As Range
Dim rng As Range: Set rng = Selection
If rng.rows.count = 1 Then Exit Function
If boolAllRange Then
Set ReturnRange = rng
Else
Set ReturnRange = rng.Offset(1).Resize(rng.rows.count - 1, rng.Columns.count)
End If
End Function
You can test it using the next Sub:
Sub testReturnRange()
Dim rng As Range
Set rng = ReturnRange 'eliminating the header
If Not rng Is Nothing Then Debug.Print rng.Address
Set rng = ReturnRange(True) 'header inclusive...
If Not rng Is Nothing Then Debug.Print rng.Address
End Sub

How would I loop this Function over column Q with VBA?

I have the following code and it does what I want it to as far as removing the data I want to remove. The only thing is I have to run it over and over and over for it to get through all of the data. How would I get this to loop over just column q?
Sub SdeleteDeclinesfoReal()
Dim sString As String
Dim MyAr
Dim i As Long
Dim delRange As Range, aCell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
'~~> Add more to the list here separated by "/"
sString = "Declined/Self ACH"
MyAr = Split(sString, "/")
With ws
For i = LBound(MyAr) To UBound(MyAr)
Set aCell = .Columns(17).Find(What:=MyAr(i), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase :=False, SearchFormat:=False)
If Not aCell Is Nothing Then
If delRange Is Nothing Then
Set delRange = .Rows(aCell.Row)
Else
Set delRange = Union(delRange, .Rows(aCell.Row))
End If
End If
Next i
End With
'...
End Sub
Loop Through Column
A Find Method Solution
Option Explicit
Sub SdeleteDeclinesfoReal()
Const FirstRow As Long = 2
Const CritCol As String = "Q"
Dim Criteria As Variant
'~~> Add more to the list here
Criteria = Array("Declined", "Self ACH")
Dim ws As Worksheet
Dim rng As Range, delRange As Range, aCell As Range
Dim i As Long
Dim sString As String
Dim FirstAddress As String
Set ws = ThisWorkbook.Sheets("Sheet1")
' Define range "Q2:Q1048576" (FirstRow, CritCol).
Set rng = ws.Cells(FirstRow, CritCol).Resize(ws.Rows.Count - FirstRow + 1)
' Define last non-blank cell.
Set rng = rng.Find(What:="*", _
LookIn:=xlValues, _
SearchDirection:=xlPrevious)
If Not rng Is Nothing Then
' Define 'non-blank' range.
Set rng = ws.Cells(FirstRow, CritCol).Resize(rng.Row - FirstRow + 1)
With rng
For i = LBound(Criteria) To UBound(Criteria)
sString = Criteria(i)
Set aCell = .Find(What:=sString, _
LookAt:=xlWhole)
If Not aCell Is Nothing Then
FirstAddress = aCell.Address
Do
If delRange Is Nothing Then
Set delRange = aCell.EntireRow
Else
Set delRange = Union(delRange, aCell.EntireRow)
End If
Set aCell = .FindNext(aCell)
' Prevent infinite loop caused by the 'FindNext' method.
Loop Until aCell.Address = FirstAddress
Else
' Criteria not found.
End If
' Prevent infinite loop when a criteria is found and one
' of the next is not.
Set aCell = Nothing
Next i
End With
If Not delRange Is Nothing Then
delRange.Select ' Test with 'Select'. Later change to 'Delete'.
Else
' Nothing cell found.
End If
Else
' All cells below first row are blank (empty or "").
End If
End Sub
A Reminder Why to Use Union
Copy the examples into a standard module, e.g. Module1 of a new workbook.
The first two procedures show how to increase efficiency using an array, but are primarily here to better understand what the last three procedures do.
Run the trio each after populating the values, and monitor how long they take and look at the ActiveSheet before and after to see the differences.
Test Union
Option Explicit
' Slow
Sub populateValuesSlow()
Const NoR As Long = 5000
Const NoC As Long = 10
Dim i As Long
Dim j As Long
For i = 1 To NoR
For j = 1 To NoC
Cells(i, j) = Int(Rnd() * (10 - 1)) + 1
Next j
Next i
End Sub
' Fast
Sub populateValuesFast()
Const NoR As Long = 5000
Const NoC As Long = 10
Dim i As Long
Dim j As Long
Dim Data As Variant
ReDim Data(1 To NoR, 1 To NoC)
For i = 1 To NoR
For j = 1 To NoC
Data(i, j) = Int(Rnd() * (10 - 1)) + 1
Next j
Next i
Cells(1, 1).Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
End Sub
' Wrong: in this case, half of the data still remains.
Sub deleteRowsOneRowAtTheTimeWrong()
Const NoR As Long = 5000
Dim i As Long
For i = 1 To NoR
Rows(i).Delete
Next i
End Sub
' Right but Slow
Sub deleteRowsOneRowAtTheTime()
Const NoR As Long = 5000
Dim i As Long
For i = NoR To 1 Step -1
Rows(i).Delete
Next i
End Sub
' Right and Fast
Sub deleteRowsWithUnion()
Const NoR As Long = 5000
Dim rng As Range
Dim i As Long
For i = 1 To NoR
If Not rng Is Nothing Then
Set rng = Union(rng, Rows(i))
Else
Set rng = Rows(i)
End If
Next i
rng.Delete
End Sub
Well let me describe your scenary:
You have a list in this case your list is
sString = "Declined/Self ACH" (for this example your list have 2 elements)
then you have a table that have at least 17 columns ( Set aCell = .Columns(17).Find) and with your program you search all rows that have in column 17 a value that is in your list then put all that "rows" in a range (delRange) and delete all rows in that range
In this point your code only find firts match for each element in your list so you Range (delRange) have maximum size equal maximum size your list (for this example 2).
OK for me:
Why you save a range with elements that you are going to delete?
you can insert a delete instruction in second loop that others user suggest you, but instead use .Findnext you use another .find
PO=17 /*PO is whatever column you want*/
For i = LBound(MyAr) To UBound(MyAr)
Set aCell = .Columns(PO).Find(What:=MyAr(i), LookIn:=xlValues)
If Not aCell Is Nothing Then
Do
.Rows(aCell.Row).Delete
Set aCell = .Columns(PO).Find(What:=MyAr(i), LookIn:=xlValues)
Loop While Not aCell Is Nothing
End If
Next i

Sum a range for a specific column

I want to build a dynamic reporting, and for that, if the header is equal to a specific text then sum the entire column below the header. This is the code that I have.
Sub FindIfSumColumn()
Dim LastRow As Long
Dim rgFound As Range
Dim mFound As Range
Dim bd As Worksheet: Set bd = Sheets("BDD")
Dim dt As Worksheet: Set dt = Sheets("DICT")
LastCol = bd.Cells(1, Columns.Count).End(xlToLeft).Column
Set mFound = dt.Range("B2")
Set rgFound = bd.Range("A1:XFD" & LastCol).Find(What:=mFound, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
If rgFound Is Nothing Then
MsgBox "Nothing"
Else
LastRow = rgFound.Cells(Rows.Count, 1).End(xlUp).Row
dt.Range("B4") = Application.WorksheetFunction.Sum(LastRow)
End If
End Sub
Logic:
Find the header
Get the row below the header
Get the last row under that header
Create your range to sum
Find sum
TIP: It will be easier if you give meaningful names to your variables. That way it will be easier to understand what they are for
Is this what you are trying?
Option Explicit
Sub FindIfSumColumn()
Dim StartRow As Long, LastRow As Long
Dim FoundColumn As String
Dim StringToFind As String
Dim ResultRange As Range
Dim sumRng As Range
Dim bd As Worksheet: Set bd = Sheets("BDD")
Dim dt As Worksheet: Set dt = Sheets("DICT")
StringToFind = dt.Range("B2").Value
Set ResultRange = bd.Cells.Find(What:=StringToFind, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns)
If ResultRange Is Nothing Then
MsgBox "Nothing"
Else
'~~> Get the row after the header
StartRow = ResultRange.Row + 1
'~~> Column of the header
FoundColumn = Split(Cells(, ResultRange.Column).Address, "$")(1)
'~~> Last row under that header
LastRow = bd.Range(FoundColumn & bd.Rows.Count).End(xlUp).Row
'~~> The range that we need to sum
Set sumRng = bd.Range(FoundColumn & StartRow & ":" & FoundColumn & LastRow)
'~~> Output
dt.Range("B4") = Application.WorksheetFunction.Sum(sumRng)
End If
End Sub
Replace, please, your code row
dt.Range("B4") = Application.WorksheetFunction.Sum(LastRow)
with
dt.Range("B4") = Application.WorksheetFunction.Sum(bd.Range(rgFound.Offset(1, 0), rgFound.Offset(lastRow, 0)))

Alter" VLOOKUP" code to run Cell by Cell not on entire range

I am tring to alter this code FindReplace_With_Offset_1 to FindReplace_With_Offset_2
FindReplace_With_Offset_1 Run on a Col Range and it works fine
I need FindReplace_With_Offset_2 to run only on each Cell in the Col Range i.e. I need each cell to be its own range, when I run it I get #NAME? for every Cell with value #N/A
Thanks
Sub FindReplace_With_Offset_1()
Dim wsFR As Worksheet, wsT As Worksheet
Dim tLR As Long, i As Long
Set wsT = ThisWorkbook.Worksheets("XXX")
Set wsFR = ThisWorkbook.Worksheets("ZZZ")
With wsT
tLR = .Range("C" & .Rows.Count).End(xlUp).Row
With .Range("B2:B" & tLR) 'The Offset Range
.Value = _
"=VLOOKUP(D2," & wsFR.Range("D1").CurrentRegion.Address(1, 1, , 1) & ",2,0)"
.Value = .Value
End With
End With
End Sub
Code2
Sub FindReplace_With_Offset_2()
Dim wsFR As Worksheet, wsT As Worksheet
Dim Rng As Range, aCell As Range
Dim tLR As Long, i As Long
Set wsT = ThisWorkbook.Worksheets("XXX")
Set wsFR = ThisWorkbook.Worksheets("ZZZ")
With wsT
tLR = .Range("C" & .Rows.Count).End(xlUp).Row
Set Rng = .Range("A2:A" & tLR)
For Each aCell In Rng
If aCell.text = "#N/A" Then
aCell.Value = _
"=VLOOKUP(aCell," & wsFR.Range("C1").CurrentRegion.Address(1, 1, , 1) & ",2,0)"
aCell.Value = aCell.Value
Else
aCell = aCell
End If
Next aCell
End With
End Sub
Maybe it's because you're trying to put the code to read a error value, and for the excel the cell value isn't the text "#N/A", try to use the IfError formula to run the verification on the desired cell, like this:
If WorksheetFunction.IfError(aCell,"Error") = "Error" Then

InStr search and commas in a cell

I have a bunch of column of rows that contain text such as:
dog,cat,mouse
bat,dog,fly
fish,beaver,horse
I'm trying to search and highlight rows that contain certain word:
Public Sub MarkDuplicates()
Dim iWarnColor As Integer
Dim rng As Range
Dim rngCell As Variant
Dim LR As Long
Dim vVal
Dim tRow
LR = Cells(Rows.Count, "B").End(xlUp).Row
Set rng = Range("B1:B" & LR)
iWarnColor = xlThemeColorAccent2
For Each rngCell In rng.Cells
tRow = rngCell.Row
If InStr(rngCell.Value, "dog") = 1 Then
rngCell.Interior.ColorIndex = iWarnColor
Else
rngCell.Interior.Pattern = xlNone
End If
Next
End Sub
This works fine so long as the word 'dog' is the first word in the comma string, so it would highlight the first row but not row two because the word 'dog' appears after 'bat'. Do I need to strip the commas out first or is there a better way of doing this?
It looks like your ultimate goal is to color the row based on whether or not 'dog' is in a cell. Here's a different way to do it that doesn't even involve VBA (this example assumes your data is all in column A):
Make a new column to the right. Use the formula =IF(NOT(ISERROR(FIND("dog",A1))),1,0). You can hide the column later so the user doesn't see it. Basically, if it has the word 'dog' somewhere, then return 1 else 0.
Select the entire first row
Under Conditional Formatting, go to New Rule
Choose Use a Formula
For your formula, try =$B2=1
Now that you've conditionally colored one row, copy and paste format to the other rows.
All rows should now update automatically.
Extra Credit: If this data is formatted as a table object, the conditional formatting should automatically carry over to new rows as they are added.
Further to my comments above
Example 1 (Using .Find and .Findnext)
Option Explicit
Public Sub MarkDuplicates()
Dim ws As Worksheet
Dim iWarnColor As Integer
Dim rng As Range, aCell As Range, bCell As Range
Dim LR As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
iWarnColor = xlThemeColorAccent2
With ws
LR = .Range("B" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B1:B" & LR)
rng.Interior.ColorIndex = xlNone
Set aCell = rng.Find(What:="dog", LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
aCell.Interior.ColorIndex = iWarnColor
Do
Set aCell = rng.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
aCell.Interior.ColorIndex = iWarnColor
Else
Exit Do
End If
Loop
End If
End With
End Sub
Screenshot
Example 2 (Using Autofilter)
For this ensure that there is a Heading in Cell B1
Option Explicit
Public Sub MarkDuplicates()
Dim ws As Worksheet
Dim iWarnColor As Integer
Dim rng As Range, aCell As Range
Dim LR As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
iWarnColor = xlThemeColorAccent2
With ws
'~~> Remove any filters
.AutoFilterMode = False
LR = .Range("B" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B1:B" & LR)
With rng
.AutoFilter Field:=1, Criteria1:="=*dog*"
Set aCell = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
End With
If Not aCell Is Nothing Then aCell.Interior.ColorIndex = iWarnColor
'~~> Remove any filters
.AutoFilterMode = False
End With
End Sub

Resources