set range using string variable for column letter - excel

I'd like to know how to write this range changing "G" to a string variable strColumn.
This is the code I want to change:
Dim lastRowElemento As Integer
lastRowElemento = Cells(Rows.Count, "G").End(xlUp).Row
Set rngElemento = ws.Range("G2:G" & lastRowElemento)

Applying OP's method, try this:
Sub TEST()
Dim ws As Worksheet, Rng As Range, sCol As String
sCol = "G"
Set ws = ThisWorkbook.Sheets("TEST") 'change as required
With ws.Columns(sCol)
Set Rng = Range(.Cells(2), .Cells(.Rows.Count).End(xlUp))
End With
End Sub

Reference a 'Non-Empty' Column Range
There are actually two requirements:
ColumnString = G (I prefer string since e.g. XFD are letters)
FirstRow = 2
If you put them together, you get G2 (think one, instead of two variables).
Since using the Find method is more reliable than using the End property in finding the bottom-most (last) non-empty cell in a column, I used it to write the RefColumn function which in your case can be utilized in the following way:
Set rngElemento = RefColumn(ws.Range("G2"))
I'll leave it up to you if you're going to test if there is data (usually you know there is), but I prefer to keep at least a 'simplified' test in the code:
If rngElemento is Nothing Then Exit Sub ' no data
' Continue...
The Code
Option Explicit
Sub RefColumnTEST()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim rg As Range: Set rg = RefColumn(ws.Range("G2"))
If rg Is Nothing Then ' the range 'G2:G1048576' is empty
MsgBox "No data.", vbCritical
Else
MsgBox rg.Address(0, 0), vbInformation
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
Meeting Your Requirements
Similarly to my preferred way, you could use the RefData function:
Function RefData( _
ByVal ws As Worksheet, _
ByVal ColumnIndex As Variant) _
As Range
On Error GoTo ClearError
With ws.Columns(ColumnIndex).Resize(ws.Rows.Count - 1).Offset(1)
Set RefData = _
.Resize(.Find("*", , xlFormulas, , , xlPrevious).Row - 1)
End With
ProcExit:
Exit Function
ClearError:
Resume ProcExit
End Function
which you can utilize in the following way:
Set rngElemento = RefData(ws, "G")
Set rngElemento = RefData(ws, 7)
' or:
Const strColumn As String = "G"
Set rngElemento = RefData(ws, strColumn)

Related

I need to use the lastrow in my range to create a code [duplicate]

This question already has answers here:
VBA: Selecting range by variables
(6 answers)
Closed 1 year ago.
I want to create a button that prints out a range of cells but the range always differs by the number of rows. I thought I could use the Lastrow feature so I do not have the manually tweak the code everytime I need to print. The Range that needs to be printed out is B2:S50 but the row number always changes therefore I thought Lastrow would be useful to save me from manually changing.
I have tried the following code(s):
Sub printproposal()
Sheets("Proposals").Activate
Dim Lastrow As Integer
Lastrow = Range("B" & Rows.Count).End(xlUp).Row
' MsgBox Lastrow
Range(Lastrow, "B"):("S2").Printout
Sheets("Proposals").Range(Cells(Lastrow, "B"),
Cells("S2")).printout
End Sub
Reference Columns Range
When it is unknown which column has the last cell with a value, you could use the RefColumns function:
Option Explicit
Sub PrintProposal()
Const wsName As String = "Proposals"
Const Cols As String = "B:S"
Const fRow As Long = 2
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim frrg As Range: Set frrg = ws.Rows(fRow).Columns(Cols) ' "B2:S2"
Dim rg As Range: Set rg = RefColumns(frrg) ' "B2:SLastRow"
rg.PrintOut
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the range from the first row of a range
' ('FirstRowRange') to the row range containing
' the bottom-most non-empty cell in the row's columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumns( _
ByVal FirstRowRange As Range) _
As Range
If FirstRowRange Is Nothing Then Exit Function
With FirstRowRange.Rows(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Function ' empty range
Set RefColumns = .Resize(lCell.Row - .Row + 1)
End With
End Function

Create range from find & findnext results [duplicate]

This question already has an answer here:
Can the Excel VBA Range.Find method be used to find multiple values?
(1 answer)
Closed 1 year ago.
I have a find function that search through a column, and there might be more than one result. Which I would like to store in a range (instead of a separate array for example).
This is what I have:
Dim searchRange As Range
Set searchRange = ActiveWorkbook.Sheets(SHEET).Range(SEARCHFOLDERCOLUMN & SEARCHSTARTROW & ":" & SEARCHFOLDERCOLUMN & lastRow)
'search for value
Dim searchResult As Range
Dim firstAddress As String
Set searchResult = searchRange.Find(what:=sSearchFolder, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not searchResult Is Nothing The
firstAddress = searchResult.Address
Do
'search for the next one
Debug.Print searchResult.Address
Set searchResult = searchRange.FindNext(searchResult)
'^^^^^ union instead of this ???
'avoid endless loop, when hitting back the first address
If firstAddress = searchResult.Address Then
'Set searchResult = tempSearchResult
Exit Do
End If
Loop While Not searchResult Is Nothing
End If
Debug.Print "out of loop"
My output:
$M$125
$M$148
$M$161
out of loop
How can I get a range like: "$M$125, $M$148, $M$161" ? Where the columns (or rows?) or 3 instead of 1 like I have now.
Thanks for your help.
Reference a 'FindNext Multi Range'
Option Explicit
Sub DebugPrintCCRGtest()
' Needs 'DebugPrintCCRG', 'RefColumn' and 'RefCriteriaColumnRange'.
DebugPrintCCRG ""
DebugPrintCCRG "Yes"
DebugPrintCCRG "No"
DebugPrintCCRG "2"
' Example Results:
' A4,A8:A9,A17
' A2:A3,A7,A12:A14,A21
' A6,A15:A16,A18:A19
' A5,A10:A11,A20
End Sub
Sub DebugPrintCCRG( _
ByVal Criteria As String)
' Needs 'RefColumn' and 'RefCriteriaColumnRange'.
Dim sFirst As String: sFirst = "A2"
Dim ws As Worksheet: Set ws = ActiveSheet ' be more specific
Dim crg As Range: Set crg = RefColumn(ws.Range(sFirst))
If crg Is Nothing Then Exit Sub
Dim ccrg As Range: Set ccrg = RefCriteriaColumnRange(crg, Criteria)
If ccrg Is Nothing Then Exit Sub
Debug.Print ccrg.Address(0, 0)
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the range combined from all the cells
' of a one-column range ('crg'), whose values are equal
' to a string ('Criteria').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCriteriaColumnRange( _
ByVal crg As Range, _
ByVal Criteria As String) _
As Range
If crg Is Nothing Then Exit Function
Dim cCell As Range: Set cCell = crg.Find(Criteria, _
crg.Cells(crg.Cells.Count), xlFormulas, xlWhole)
If cCell Is Nothing Then Exit Function
Dim drg As Range: Set drg = cCell
Dim FirstAddress As String: FirstAddress = cCell.Address
Do
Set drg = Union(drg, cCell)
Set cCell = crg.FindNext(cCell)
Loop Until cCell.Address = FirstAddress
If drg Is Nothing Then Exit Function
Set RefCriteriaColumnRange = drg
End Function

vba excel to highlight cell in yellow

How can highlight in yellow a cell that have a specific word in it?
I have data in colum B and F with the word "No Game".
How can I have this in a vba in excel?
Thanks
Although this question has already been answered, I'd take my chance, showing how easy this is using conditional formatting (screenshots are minimised a bit):
Result looks like this:
Good luck
Highlight Matches (For Each...Next)
Copy the complete code into a standard module, e.g. Module1.
Adjust (play with) the values in the constants section.
Option Explicit
Sub HighlightColumns()
' Needs the 'RefColumn' and 'RefCombinedRange' functions.
Const ProcTitle As String = "Highlight Columns"
Const wsName As String = "Sheet1"
Const FirstCellsList As String = "B2,H2"
Const hCriteria As String = "No Game"
Const hColor As Long = vbYellow
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
' Write the list of the first cells' addresses to an array ('FirstCells').
Dim FirstCells() As String: FirstCells = Split(FirstCellsList, ",")
Dim scrg As Range ' Source Column Range
Dim sfCell As Range ' Source First Cell
Dim sCell As Range ' Source Cell
Dim hrg As Range ' Highlight Range
Dim n As Long ' Columns Counter
' Combine all matching cells into the Highlight Range.
For n = 0 To UBound(FirstCells)
Set sfCell = ws.Range(FirstCells(n))
Set scrg = RefColumn(sfCell)
If Not scrg Is Nothing Then ' found data in column range
For Each sCell In scrg.Cells
If StrComp(CStr(sCell.Value), hCriteria, vbTextCompare) = 0 Then
Set hrg = RefCombinedRange(hrg, sCell)
'Else ' not a match
End If
Next sCell
Set scrg = Nothing
'Else ' no data in current column range
End If
Next n
' Highlight and inform.
If Not hrg Is Nothing Then ' Highlight Criteria found
hrg.Interior.Color = hColor
MsgBox "Highlighted cells equal to '" & hCriteria & "'.", _
vbInformation, ProcTitle
Else ' no Highlight Criteria found
MsgBox "No occurrences of '" & hCriteria & "' found.", _
vbExclamation, ProcTitle
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to a range combined from two ranges.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCombinedRange( _
ByVal CombinedRange As Range, _
ByVal AddRange As Range) _
As Range
If CombinedRange Is Nothing Then
Set RefCombinedRange = AddRange
Else
Set RefCombinedRange = Union(CombinedRange, AddRange)
End If
End Function

What is the fastest way to pull data from one sheet to another using VBA

I have and excel file with 2 tabs, one is 166K rows and the other is 400K rows. Previously we were manually performing vlookups to pull data from the 400k row tab into the 166k row tab. I want to automate this some using VBA but am having issues with speed.
I tried an IF formula but that ran for over 30 minutes before I killed the process
For i = 2 To Assign.UsedRange.Rows.Count
For x = 2 To HR.UsedRange.Rows.Count
If Assign.Cells(i, 1 ) = HR.Cells(x,1) Then
Assign.Cells(i, 9) = HR.Cells(x, 3)
End If
Next x
Next i
and now I'm trying a vlookup for VBA but that also is taking a long time.
For x = 2 To Assign.UsedRange.Rows.Count
On Error Resume Next
Worksheets("Assignments").Cells(x, 9).Value =
Application.WorksheetFunction.VLookup(Worksheets("Assignments").Cells(x, 5).Value,
Worksheets("Workforce").Range("A:AX"), 5, 0)
On Error GoTo 0
Next x
any suggestions on how to speed this up? I tried using Access but the files were too big.
A VBA Lookup
This took roughly 13 seconds on my machine (Windows 10, Office 2019 64bit) for 400k vs 160k of integers.
An optimized (using arrays and Application.Match applied to the lookup column range) Match version took the same amount of time for 10 times fewer data.
Since your data probably isn't integers, your feedback is highly appreciated.
Adjust the values in the constants section.
Option Explicit
Sub VBALookup()
Const sName As String = "Workforce" ' Source Worksheet Name
Const slFirst As String = "E2" ' Source Lookup Column First Cell Address
Const svCol As String = "I" ' Source Value Column
Const dName As String = "Assignments" ' Destination Worksheet Name
Const dlFirst As String = "E2" ' Destination Lookup First Cell Address
Const dvCol As String = "I" ' Destination Value Column
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create references to the Source Ranges.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(slFirst)
Dim slrg As Range: Set slrg = RefColumn(sfCell) ' lookup range
If slrg Is Nothing Then Exit Sub
Dim svrg As Range: Set svrg = slrg.EntireRow.Columns(svCol) ' read value
' Create references to the Destination Ranges.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dlFirst)
Dim dlrg As Range: Set dlrg = RefColumn(dfCell) ' lookup value
If dlrg Is Nothing Then Exit Sub
Dim dvrg As Range: Set dvrg = dlrg.EntireRow.Columns(dvCol) ' write value
' Write the 'INDEX/MATCH' formula to a variable.
Dim dFormula As String
dFormula = "=IFERROR(INDEX('" & sName & "'!" & svrg.Address(, 0) _
& ",MATCH(" & dfCell.Address(0, 0) _
& ",'" & sName & "'!" & slrg.Address(, 0) & ",0)),"""")"
' Take a look in the Immediate window ('Ctrl + G')
'Debug.Print "Source", slrg.Address(, 0), svrg.Address(, 0)
'Debug.Print "Destination", dlrg.Address(, 0), dvrg.Address(, 0)
'Debug.Print "Formula", dFormula
' Write the formula to the Destination Value Range
' and convert the formulas to values.
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
dvrg.Formula = dFormula
dvrg.Value = dvrg.Value
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the range from the first cell
' of a range ('rg') through the bottom-most non-empty cell
' of the range's column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal rg As Range) _
As Range
If rg Is Nothing Then Exit Function
With rg.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
If rg Is Nothing Then Exit Function
Dim rData As Variant
If rg.Rows.Count + rg.Columns.Count = 2 Then
ReDim rData(1 To 1, 1 To 1): rData(1, 1) = rg.Value
Else
rData = rg.Value
End If
GetRange = rData
End Function
I would try with the find method instead of an inner loop. You have just to customize your file references and ranges.
Sub FindMatches()
Dim shtOld As Worksheet, shtNew As Worksheet
Dim oldRow As Integer
Dim newRow As Integer
Dim i As Integer, id, f As Range
i = 1
Set shtOld = ThisWorkbook.Sheets("Assign")
Set shtNew = ThisWorkbook.Sheets("HR")
For oldRow = 2 To shtOld.UsedRange.Rows.Count
id = shtOld.Cells(oldRow, 1)
Set f = shtNew.Range("A1:A1000").Find(id, , xlValues, xlWhole)
If Not f Is Nothing Then
With shtOld.Rows(i)
.Cells(1).Value = shtOld.Cells(oldRow, 1)
End With
i = i + 1
End If
Next oldRow
End Sub

Find particular text, Select, and Highlight

I want to find, and highlight cells that have a particular value.
In this example I'm searching for the number 2.
The code finds and highlights the cells with the number 2, but it also highlights cells with the number 22, and 23 because they contain the number 2.
'Find Search Values on Sheet and Highlight
Sub Find_And_Highlight()
Dim Searchfor As String
Dim FirstFound As String
Dim Lastcell As Range
Dim FoundCell As Range
Dim rng As Range
Dim myRange As Range
Set myRange = ActiveSheet.UsedRange
Set Lastcell = myRange.Cells(myRange.Cells.Count)
Searchfor = "2"
Set FoundCell = myRange.Find(what:=Searchfor, after:=Lastcell)
'Test to see if anything was found
If Not FoundCell Is Nothing Then
FirstFound = FoundCell.Address
Else
GoTo NothingFound
End If
Set rng = FoundCell
'Loop until cycled through all finds
Do Until FoundCell Is Nothing
'Find next cell with Searchfor value
Set FoundCell = myRange.FindNext(after:=FoundCell)
'Add found cell to rng range variable
Set rng = Union(rng, FoundCell)
'Test to see if cycled through to first found cell
If FoundCell.Address = FirstFound Then Exit Do
Loop
'Highlight cells that contain searchfor value
rng.Interior.ColorIndex = 34
Exit Sub
'Error Handler
NothingFound:
MsgBox "No values were found in this worksheet"
End Sub
Please look at the comment provided by #Craig which you need to implement. i.e. you need to modify the Foundcell line like below:
Set FoundCell = myRange.Find(what:=Searchfor, after:=Lastcell, lookat:=xlWhole)
Caution: This option modifies the user's search settings in Excel so in future make sure to uncheck below option in the Find box.
However, since you are changing the background color of the cells, you really do not need VBA for this purpose. You can use Conditional Formatting | Highlight Cells Rules | Equal To as shown below:
And then fill in the value as appropriate:
Outcome will appear like this:
Highlight Found Cells
Uncomment the Debug.Print lines in the FindAndHighlight procedure to better understand its behavior.
Option Explicit
Sub FindAndHighlight()
' You could use these constants ('ByVal') as arguments of this procedure,
' when you could call it with 'FindAndHighlight "2", 34' from yet another
' procedure.
Const SearchString As String = "2"
Const cIndex As Long = 34
If ActiveSheet Is Nothing Then Exit Sub ' if run from add-in
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub ' if e.g. chart
'Debug.Print "Worksheet Name: " & ActiveSheet.Name
Dim srg As Range: Set srg = ActiveSheet.UsedRange
'Debug.Print "Source Range Address: " & srg.Address(0, 0)
Dim frg As Range: Set frg = refFindStringInRange(srg, SearchString)
If frg Is Nothing Then
MsgBox "No occurrence of '" & SearchString & "' found in range '" _
& srg.Address(0, 0) & "' of worksheet '" & srg.Worksheet.Name _
& "'.", vbCritical, "Nothing Found"
Exit Sub
End If
'Debug.Print "Found Range Address: " & frg.Address(0, 0)
HighLightRangeUsingColorIndex frg, cIndex
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to a range combined of all cells
' whose contents are equal to a string.
' Remarks: The search is case-insensitive ('MatchCase') and is performed
' by rows ('SearchOrder') ascending ('SearchDirection',
' ('FindNext')), starting with the first cell ('After')
' of each area of the range.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function refFindStringInRange( _
ByVal SearchRange As Range, _
ByVal SearchString As String) _
As Range
If SearchRange Is Nothing Then Exit Function
Dim frg As Range
Dim arg As Range
Dim lCell As Range
Dim fCell As Range
Dim FirstAddress As String
For Each arg In SearchRange.Areas
Set lCell = arg.Cells(arg.Rows.Count, arg.Columns.Count)
Set fCell = Nothing
' By modifying the parameters of the arguments of the 'Find' method
' you can change the behavior of the function in many ways.
Set fCell = arg.Find(SearchString, lCell, xlFormulas, xlWhole, xlByRows)
If Not fCell Is Nothing Then
FirstAddress = fCell.Address
Do
If frg Is Nothing Then
Set frg = fCell
Else
Set frg = Union(frg, fCell)
End If
Set fCell = arg.FindNext(After:=fCell)
Loop Until fCell.Address = FirstAddress
End If
Next arg
If Not frg Is Nothing Then
Set refFindStringInRange = frg
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Highlights the cells of a range using a color index.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub HighLightRangeUsingColorIndex( _
ByVal rg As Range, _
ByVal cIndex As Long)
If rg Is Nothing Then Exit Sub
If cIndex < 1 Or cIndex > 56 Then Exit Sub
rg.Interior.ColorIndex = cIndex
End Sub

Resources