I'm trying to get a sub to work that will color fields based on when the values "TRUE" or "FALSE" appears. I've already asked the below question, and have arrived at the code, also below.
VBA Excel Format Range when value is found
Option Explicit
Public Sub MarkCellsAbove()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
Dim v As Variant
Dim i As Long, j As Long, n As Long, m As Long, r As Long, y As Long
Dim rng As Range
Dim rCell As Range
Dim DynamicArea As Range
Dim t As Double
' get last row in column C
n = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
' get last column from A
y = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
' set dynamic area to above values
Set DynamicArea = ws.Range(Cells(1, 1), Cells(n, y))
' clear existing colors over the WHOLE column to minimize file size
DynamicArea.Interior.ColorIndex = xlColorIndexNone
For Each rCell In DynamicArea
Select Case rCell.Text
Case "TRUE"
Set rng = rCell.Offset(-2, 0)
rng.Interior.ColorIndex = 4
Case "FALSE"
Set rng = rCell.Offset(-2, 0)
rng.Interior.ColorIndex = 5
End Select
Next
End Sub
This works well - I am able to color the cell 2 rows above where FALSE or TRUE is found. However - I would like to color not just this cell, but all cells in the range specified by Offset. So, if I specify 8 cells above, I would like to color 8 cells.
I hope someone can help - I'm so close to finishing this!
Try
Set rng = Range(rCell.Offset(-8, 0), rCell.Offset(-1, 0))
Note that you will get a runtime error if rCell is not at least in row 9
Related
I would like to write a UDF (user defined function, aka. macro) that will be used in each of the green cells. In this function/macro in want to get the length of the longest string in the framed cells next to my current group of green cells. In order to do this in the macro I need to determine a range that represents all of the framed cells next to the current cell. (This calculation should result the same range object for each cell in one green group but a different one from group to group.) How would you get this Range?
My first try was this:
Range(Application.Caller.Offset(0, -1).End(xlUp),_
Application.Caller.Offset(0, -1).End(xlDown))
But this
doesn't work
would give false range if the caller cell is the uppermost or lowermost cell of a group.
I would need something like ActiveCell.Offset(0, -1).CurrentRegion, but in the vertical direction only.
Try this:
Function findlongest()
Dim fullcolumn() As Variant
Dim lastrow As Long
Dim i As Long, j As Long, k As Long
Dim tmax As Long
tmax = 0
With Application.Caller
lastrow = .Parent.Cells(.Parent.Rows.Count, .Column - 1).End(xlUp).Row
fullcolumn = .Parent.Range(.Parent.Cells(1, .Column - 1), .Parent.Cells(lastrow, .Column - 1)).Value
For j = .Row To 1 Step -1
If fullcolumn(j, 1) = "" Then
j = j + 1
Exit For
ElseIf j = 1 Then
Exit For
End If
Next j
For i = .Row To UBound(fullcolumn, 1)
If fullcolumn(i, 1) = "" Then
i = i - 1
Exit For
ElseIf i = UBound(fullcolumn, 1) Then
Exit For
End If
Next i
'to get the range
Dim rng As Range
Set rng = .Parent.Range(.Parent.Cells(j, .Column - 1), Parent.Cells(i, .Column - 1))
'then do what you want with rng
'but since you already have the values in an array use that instead.
'It is quciker to iterate and array than the range.
For k = j To i
If Len(fullcolumn(k, 1)) > tmax Then tmax = Len(fullcolumn(k, 1))
Next k
findlongest = tmax
End With
End Function
Are you after something like the code below:
Option Explicit
Sub GetLeftRange()
Dim myRng As Range
Set myRng = ActiveCell.Offset(, -1).CurrentRegion
Debug.Print myRng.Address
End Sub
Note: ActiveCell is one of the cells you marked as green.
This is an example of setting each range using Area.
Sub test()
Dim Ws As Worksheet
Dim rngDB As Range
Dim rngA As Range, rng As Range
Set Ws = ActiveSheet
With Ws
Set rngDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
Set rngA = rngDB.SpecialCells(xlCellTypeConstants, xlTextValues)
For Each rng In rngA.Areas
rng.Offset(, 1).Select '<~~ select is not required but is intended to be visualized
Next rng
End With
End Sub
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'
I am trying to run a macro on 3 different ranges, one after another. Once the range is selected, the code works just fine (where variables F and L are defined). I would like to set r1-r3 as Ranges I need and then use a string variable to concatenate the range numbers together. This code works, but doesn't provide the starting and ending row number in the range selected. This is vital because it tells the "TableCalc" macro when to start and stop the code. I would then like to move on to the next range. Thanks for your help.
Sub TestRangeBC()
WS.Select
Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim rngx As String
Dim num As Integer
Dim rng As Range
Set r1 = WS.Range("ONE")
Set r2 = WS.Range("TWO")
Set r3 = WS.Range("THREE")
For num = 1 To 3
rngx = "r" & num
Set rng = Range(rngx)
Dim F As Integer
Dim L As Integer
F = rng.Row + 1
L = rng.Row + rng.Rows.Count - 2
Cells(F, 8).Select
Do While Cells(F, 8) <> "" And ActiveCell.Row <= L
'INSERT SITUATIONAL MACRO
Call TableCalc
WS.Select
ActiveCell.Offset(1, 0).Select
Loop
Next num
End Sub
This is not the answer (as part of your code and what you are trying to achieve is unclear yet), but it is a "cleaner" and more efficient way to code what you have in your original post.
Option Explicit
Dim WS As Worksheet
Your original Sub shorten:
Sub TestRangeBC()
' chanhe WS to your Sheet name
Set WS = Sheets("Sheet1")
Call ActiveRange("ONE")
Call ActiveRange("TWO")
Call ActiveRange("THREE")
End Sub
This Sub gets the Name of the Named Range (you set in your workbook) as a String, and sets the Range accordingly.
Sub ActiveRange(RangeName As String)
Dim Rng As Range
Dim F As Integer
Dim L As Integer
Dim lRow As Long
With WS
Set Rng = .Range(RangeName)
' just for debug purpose >> to ensure the right Range was passed and set
Debug.Print Rng.Address
F = Rng.Row + 1
L = Rng.Row + Rng.Rows.Count - 2
lRow = F
' what you are trying to achieve in this loop is beyond me
Do While .Cells(F, 8) <> "" And .Cells(lRow, 8).Row <= L
Debug.Print .Cells(lRow, 8).Address
'INSERT SITUATIONAL MACRO
' Call TableCalc
' not sure you need to select WS sheet again
WS.Select
lRow = lRow + 1
Loop
End With
End Sub
What are you trying to test in the loop below, what are the criteria of staying in the loop ?
Do While Cells(F, 8) <> "" And ActiveCell.Row <= L
it's really hard to tell what you may want to do
but may be what follows can help you clarifying and (hopefully) doing it!
first off, you can't "combine" variable names
So I'd go with an array of named ranges names (i.e. String array) to be filled by means of a specific sub:
Function GetRanges() As String()
Dim ranges(1 To 3) As String
ranges(1) = "ONE"
ranges(2) = "TWO"
ranges(3) = "THREE"
GetRanges = ranges
End Function
so that you can clean up your "main" sub code and keep only more relevant code there:
Sub TestRangeBC()
Dim r As Variant
Dim ws As Worksheet
Set ws = Worksheets("Ranges") '<--| change "Ranges" to your actual worksheet name
For Each r In GetRanges() '<--| loop through all ranges names
DoIt ws, CStr(r) '<--| call the range name processing routine passing worksheet and its named range name
Next r
End Sub
the "main" sub loops through the named ranges array directly collected from GetRanges() and calls DoIt() to actually process the current one:
Sub DoIt(ws As Worksheet, rangeName As String)
Dim cell As Range
Dim iRow As Long
With ws.Range(rangeName) '<--| reference the passed name passed worksheet named range
For iRow = .Rows(2).Row To .Rows(.Rows.Count - 2).Row '<--| loop through its "inner" rows (i.e. off 1st and last rows)
Set cell = ws.Cells(iRow, 8) '<--| get current row corresponding cell in column "F"
If cell.value = "" Then Exit For '<--| exit at first blank column "F" corresponding cell
TableCalc cell '<-- call TableCalc passing the 'valid' cell as its parameter
Next iRow
End With
End Sub
I'm trying to call a Sub (New_Row) when the first empty row (minus the last column) is filled. I'm having trouble with how to reference a range of cells in the If statement toward the end.
Sub Data_Added()
'Check if anything has been entered into the first empty row in "Data"
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Sheets("Data").Select
Set sht = Worksheets("Data")
Set StartCell = Range("A1").End(xlDown).Select
Worksheets("Data").UsedRange
LastRow = StartCell.SpecialCells(xlCellTypeLastCell).Row
LastColumn = StartCell.SpecialCells(xlCellTypeLastCell).Column
Set InputRange = sht.Range(StartCell, sht.Cells(LastRow + 1, LastColumn - 1))
If InputRange Is Not Nothing Then
Call New_Row
End If
End Sub
I've seen people using the Application.Intersect method, but I'm not sure if an intersect makes sense for just one row of cells. Totally new to VBA, though, so I don't know. Right now I'm getting an "Invalid use of Object" error pointing at the "Nothing" in the If statement.
Dim y As Long, lastx As Long
Dim sht As Worksheet
y = 1 'Row you want to check
Set sht = ThisWorkbook.Worksheets("Sheet1")
lastx = sht.Cells(y, sht.Columns.Count).End(xlToRight).Column - 1
If WorksheetFunction.CountA(Range(Cells(y, 1), Cells(y, lastx))) <> 0 Then 'Call New_Row when the row you are checking is empty
Call New_Row
End If
Have you tried something like this?
I am very new to VBA coding and need some help. I'm looking for a code that selects ranges based on the value of differet cells.
In my sheet i have 7 cells that have a formula which give the cell a "X" if i want an range is to be selected:
If I33 = "X" then select A1: S31 (I33 has a formula)
If I34 = "X" then select T1: AH31 (I33 has a formula)
I have 7 of these ....
What I'm looking for; if one or more of I33, I34, i35, I36, I37, I38 or I39 has an "X", the respective area (example A1:S31, there are 7 different ranges) should be selected.
Thanks for any help :-)
you can try this
Option Explicit
Sub main()
Dim xRangeAdress As Range, rangesAddress() As Range, rangeToSelect As Range, cell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("X-Sheet") '<== change it as per your actual sheet name
Set xRangeAdress = ws.Range("I33:I39") '<== set the range with "X" formulas: change "I33:I39" as per your actual needs
Call SetRangeAddresses(rangesAddress(), ws) ' call the sub you demand the addresses settings to
For Each cell In xRangeAdress 'loop through "X" cells
If UCase(cell.Value) = "X" Then Set rangeToSelect = MyUnion(rangeToSelect, rangesAddress(cell.Row - 33 + 1)) ' if there's an "X" then update 'rangeToSelect' range with corresponding range
Next cell
rangeToSelect.Select
End Sub
Sub SetRangeAddresses(rangeArray() As Range, ws As Worksheet)
ReDim rangeArray(1 To 7) As Range '<== resize the array to as many rows as cells with "X" formula
With ws ' type in as many statements as cells with "X" formula
Set rangeArray(1) = .Range("A1:S31") '<== adjust range #1 as per your actual needs
Set rangeArray(2) = .Range("T1:AH31") '<== adjust range #2 as per your actual needs
Set rangeArray(3) = .Range("AI1:AU31") '<== adjust range #3 as per your actual needs
Set rangeArray(4) = .Range("AU1:BK31") '<== adjust range #4 as per your actual needs
Set rangeArray(5) = .Range("BL1:BT31") '<== adjust range #5 as per your actual needs
Set rangeArray(6) = .Range("BU1:CD31") '<== adjust range #6 as per your actual needs
Set rangeArray(7) = .Range("CE1:CJ31") '<== adjust range #7 as per your actual needs
End With
End Sub
Function MyUnion(rng1 As Range, rng2 As Range) As Range
If rng1 Is Nothing Then
Set MyUnion = rng2
Else
Set MyUnion = Union(rng1, rng2)
End If
End Function
I added comments to let you study and develop his code for your further knowledge
Just to have a different solution (regarding what you need choose one of them):
Option Explicit
Function MainFull(Optional WS As Variant) As Range
If VarType(WS) = 0 Then
Set WS = ActiveSheet
ElseIf VarType(WS) <> 9 Then
Set WS = Sheets(WS)
End If
With WS
Dim getRng As Variant, outRng As Range, i As Long
getRng = WS.Range("I33:I39").Value
For i = 1 To 7
If getRng(i, 1) = "x" Then
If MainFull Is Nothing Then
Set MainFull = .Range(Array("A1:S31", "T1:AL31", "AM1:BE31", "BF1:BX31", "BY1:CQ31", "CR1:DJ31", "DK1:EC31")(i - 1)) '<- change it to fit your needs
Else
Set MainFull = Union(MainFull, .Range(Array("A1:S31", "T1:AL31", "AM1:BE31", "BF1:BX31", "BY1:CQ31", "CR1:DJ31", "DK1:EC31")(i - 1))) '<- change it to fit your needs
End If
End If
Next
End With
End Function
Function MainArray(Optional WS As Variant) As Variant
If VarType(WS) = 0 Then
Set WS = ActiveSheet
ElseIf VarType(WS) <> 9 Then
Set WS = Sheets(WS)
End If
With WS
Dim getRng As Variant, outArr() As Variant, i As Long, j As Long
getRng = WS.Range("I33:I39").Value
i = Application.CountIf(WS.Range("I33:I39"), "x")
If i = 0 Then Exit Function
ReDim outArr(1 To i)
For i = 1 To 7
If getRng(i, 1) = "x" Then
j = j + 1
Set outArr(j) = .Range(Array("A1:S31", "T1:AL31", "AM1:BE31", "BF1:BX31", "BY1:CQ31", "CR1:DJ31", "DK1:EC31")(i - 1)) '<- change it to fit your needs
End If
Next
End With
MainArray = outArr
End Function
MainFull returns the whole range for all marked ranges while MainArray returns an array which holds all ranges which are marked with "x".
How to use it:
For MainFull you can simply set the range via Set myRange = MainFull("Sheet1"). This way it can easily used within another macro (sub) to copy/paste it somewhere.
But if you need to repeat this process for every set range (which is marked by "x") then the second sub is needed like:
Dim myRange As Variant
For Each myRange In MainArray("Sheet1")
....
Next
Then do all the stuff via myRange. If you still have any questions, just ask ;)