I'm trying to write a macro that would identify the last timestamp within a column, add a defined number of days and update a due date for every column in my data set, until it reaches a blank column.
This is a screenshot of the data set where I want the calc to run:
For other calculations, I'm using the ActiveCell.Offset to navigate my spreadsheet and run the calculations, but using it for this case is getting very confusing.
Sample of code for existing calculations:
ws.Range("B74").Select
Do Until ActiveCell.Offset(0, 1).Value = ""
ActiveCell.Offset(-23, 1).Formula = "=Round(((R[-2]C[0]+R[-4]C[0])/R[-14]C[0])*100,2)"
If IsError(ActiveCell.Offset(-23, 1)) Then ActiveCell.Offset(-23, 1).Value = "0"
ActiveCell.Offset(0, 1).Select
Loop
In your case I would define an user-defined function (place the macro in a standard module) and then use that function inside the sheet as formula. The function returns the value of the last non empty cell and you then can perform your calculation directly in the sheet. Value2 is used to get the underlying value of the cell without taking formats into account.
Looks like you're interested in the navigation part (title of question). I show you three ways to get the last (I hope I understood your definition of last correctly) non empty cell in a range with a width of 1 column:
Looping through range (getLastValueWithLoop)
Using .End(xlUp) (getLastValueWithEnd)
Writing range values to array and then loop the array (fastest) (getLastValueWithArrayLoop)
I also included a function (updateDueDateInEachColumn) that goes through each column and updates the due date programmatically to not have to use the user-defined function.
Btw: You could prolly ditch using macros and just use a normal formula (see screenshot).
Code:
' **
' Get the value of the last non empty cell in rng
' #param {Range} rng Range to look in, 1 column only
' #return {Variant} Returns the value of the last non empty cell
' or false if all cells are empty
' Example:
' Use following function inside a sheet:
' =getLastValueWithLoop(A2:A6)
Public Function getLastValueWithLoop(rng As Range) As Variant
Dim i As Long
' Loop through range and check if cell is not empty
' Starts at the bottom and moves 1 cell up each time
For i = rng.Cells.Count To 1 Step -1
If rng(i).Value2 <> "" Then
getLastValueWithLoop = rng(i).Value
Exit Function
End If
Next
' if no value in range set to false
getLastValueWithLoop = False
End Function
' **
' Get the value of the last non empty cell in rng
' #param {Range} rng Range to look in, 1 column only
' #return {Variant} Returns the value of the last non empty cell
' or false if all cells are empty
' Example:
' Use following function inside a sheet:
' =getLastValueWithEnd(A2:A6)
Public Function getLastValueWithEnd(rng As Range) As Variant
Dim i As Long
Dim lastCell As Range
Dim lastNonEmptyCell As Range
' Set last cell in range
Set lastCell = rng(rng.Cells.Count)
' Use .end(xlup) to get first non empty
' This is the same as using the keys CTRL + Up
If lastCell <> "" Then
' Needs to check if last cell is empty first as else
' end(xlup) would move up even if the cell is non empty
' Set as last non empty cell if not empty
getLastValueWithEnd = lastCell.Value2
Exit Function
Else
' Use end(xlup) to get the first non empty cell moving up from
' the last cell. Check if the cell found with end(xlup) is inside the range
' with .Intersect as end(xlup) can move outside the range provided
' If it is inside the range set last non empty cell
If Not Application.Intersect(rng, lastCell.End(xlUp)) Is Nothing Then
getLastValueWithEnd = lastCell.End(xlUp).Value2
Exit Function
End If
End If
' if no value in range set to false
getLastValueWithEnd = False
End Function
' **
' Get the value of the last non empty cell in rng
' #param {Range} rng Range to look in, 1 column only
' #return {Variant} Returns the value of the last non empty cell
' or false if all cells are empty
' Example:
' Use following function inside a sheet:
' =getLastValueWithArrayLoop(A2:A6)
Public Function getLastValueWithArrayLoop(rng As Range) As Variant
Dim rngAsArray As Variant
Dim i As Long
' Write the rng values into an array
' This produces a two dimensional array
rngAsArray = rng.Value2
' Loop through the array, move from bottom up and
' return first non empty cell
For i = UBound(rngAsArray, 1) To LBound(rngAsArray, 1) Step -1
If rngAsArray(i, 1) <> "" Then
getLastValueWithArrayLoop = rngAsArray(i, 1)
Exit Function
End If
Next
' if no value in range set to false
getLastValueWithArrayLoop = False
End Function
' **
' Check rngColumn for last value (exit if none found) and
' update rngDueDate then move one column to the right etc.
' This macro relies on the function getLastValueWithLoop.
' #param {Range} rngColumn First column range to get last value in
' #param {Range} rngDueDate First cell to update due date in
' Example call in macro:
' updateDueDateInEachColumn Range("B2:B6"), Range("B7")
Public Sub updateDueDateInEachColumn(rngColumn As Range, rngDueDate As Range)
Dim rng As Range
Dim lastValue As Variant
' Loop until column is empty
Do
' Get last value of column range, returns false if no value found
lastValue = getLastValueWithLoop(rngColumn)
If lastValue = False Then
' Exit the loop if no value was found
Exit Do
Else
' Update due date
rngDueDate = lastValue + 10 ' TODO: add your calculation here
End If
' Offset column and due date range by one column
Set rngColumn = rngColumn.Offset(, 1)
Set rngDueDate = rngDueDate.Offset(, 1)
Loop
End Sub
Example usage of the functions inside a sheet:
Related
I am trying to copy and paste a range in values without using the clipboard, below code works but doesn't copy in values (includes forumlas etc):
any ideas as how to make this work?
NbRowsPnLD1 = PnLD1WS.Range("A1").End(xlDown).Row
PnLD1WS.Range(PnLD1WS.Cells(1, 1), PnLD1WS.Cells(NbRowsPnLD1, 228)).Copy(PnLD2WS.Cells(1, 1)).PasteSpecial xlPasteValues
Copy the Values of a Range by Assignment
Option Explicit
Sub CopyByAssignment()
' It is assumed that 'PnLD1WS' and 'PnLD2WS' are the code names
' of two worksheets in the workbook containing this code.
' Calculate the last row,
' the row with the last non-empty cell in the column.
' Most of the time you want to use '.End(xlUp)' instead:
Dim slRow As Long
slRow = PnLD1WS.Cells(PnLD1WS.Rows.Count, "A").End(xlUp).Row
' ... because if you have empty cells in the column, it will reference
' the whole range regardlessly.
' The following will 'stop' at the first empty cell and may not reference
' the whole desired column range.
'slRow = PnLD1WS.Range("A1").End(xlDown).Row ' not recommended
' Reference the source range (the range to be copied from).
Dim srg As Range
Set srg = PnLD1WS.Range("A1", PnLD1WS.Cells(slRow, "HT"))
' Reference the destination range (the range to be written (pasted) to).
' Use 'Resize' to make it the same size as the source range.
Dim drg As Range
Set drg = PnLD2WS.Range("A1").Resize(srg.Rows.Count, srg.Columns.Count)
' Copy by assignment.
drg.Value = srg.Value
End Sub
Something like
With PnLD1WS.Range(PnLD1WS.Cells(1, 1), PnLD1WS.Cells(NbRowsPnLD1, 228))
PnLD2WS.Cells(1, 1).Resize(.Rows.Count,.Columns.Count).Value2 = .Value2
End With
I am attempting to get the row number of the first visible row after I filter the data. I need the row number so I can select the top cell in that respective row to select all cells below the active cell. I am very much a beginner to VBA so I'm not familiar with essentially any of it.
Here's the example of the code I need to modify:
Dim bidNum As String
Dim bidFull As String
bidNum = "123" 'sample number
bidFull = "Bid-" + bidNum + ".csv"
ActiveSheet.ListObjects("PriceExp").Range.AutoFilter Field:=1, Criteria1:=bidFull 'filters data by Bid #
Range("B####", Range("B####").End(xlDown)).Value = "sample name" '#### is where I need to know the current row number after data is filtered
Range("C####", Range("C####").End(xlDown)).Value = "sample state"
'etc. for more columns
In order to get the rows visible after the filter, you can Set a Range object using Range.SpecialCells(xlCellTypeVisible) property of the ListObject.
After, you need to loop through the Areas of the Non-Contiguous Filtered range.
You can set each column Range, and by using the Application.Union command you can merge ranges together.
Read HERE more about the Union function.
Code
Option Explicit
Sub FillColumnAccordingToFilteredRows()
Dim bidNum As String
Dim bidFull As String
Dim PriceLObj As ListObject
bidNum = "123" 'sample number
bidFull = "Bid-" + bidNum + ".csv"
Set PriceLObj = ActiveSheet.ListObjects("PriceExp") ' set the ListObject
PriceLObj.Range.AutoFilter Field:=1, Criteria1:=bidFull ' filters data by Bid #
Dim VisRng As Range, VisArea As Range, VisRow As Range
Dim ColBRng As Range, ColCRng As Range
' get the visible range of the filteres list object
Set VisRng = PriceLObj.Range.SpecialCells(xlCellTypeVisible)
' === set column B and column C Range ===
For Each VisArea In VisRng.Areas ' loop through areas in non-contigous filtered range
' loop through rows in area
For Each VisRow In VisRng.Rows
If VisRow.Row <> 1 Then ' not header row
' set and Merge ranges for column B range
If Not ColBRng Is Nothing Then
Set ColBRng = Application.Union(ColBRng, Range("B" & VisRow.Row))
Else
Set ColBRng = Range("B" & VisRow.Row)
End If
' set and Merge ranges for column C range
If Not ColCRng Is Nothing Then
Set ColCRng = Application.Union(ColCRng, Range("C" & VisRow.Row))
Else
Set ColCRng = Range("C" & VisRow.Row)
End If
End If
Next VisRow
Next VisArea
' make sure column B range is not empty (otherwise will pop an error)
If Not ColBRng Is Nothing Then ColBRng.Value2 = "sample name"
' make sure column C range is not empty (otherwise will pop an error)
If Not ColCRng Is Nothing Then ColCRng.Value2 = "sample state"
End Sub
Is it possible to offset to the right of a cell based on column headers? I have some code that loops through a range, and if it finds a specific value it will offset 12 columns to the right. Instead of saying Offset(,12), is there a way I can say offset to the right in that same row to the column with the header I want?
For example if column B is named "host" and my range is
rng = ws.range("B1:B20")
and column N is named "country", I don't want to write:
offset(,12).value = ...
Instead if there is something like:
offset(to column: country).value =...
The reason I ask for this is to not specific an offset number to make the code more resilient to any changes that may happen to my excel worksheet.
I hope the explanation is clear. thanks!
Try the Function below, will return the number of columns you need to Offset from your Rng to the "Header" you are looking for.
Option Explicit
Function OffesttoHeader(CurrentCol As Long, FindRng As Range, HeaderStr As String) As Long
Dim HeaderRng As Range
Set HeaderRng = FindRng.Find(what:=HeaderStr)
If Not HeaderRng Is Nothing Then
OffesttoHeader = HeaderRng.Column - CurrentCol + 1
Else
OffesttoHeader = -10000 ' raise to a large value >> as an error
End If
End Function
Test Sub Code (to test the function above):
Sub Test()
Dim ws As Worksheet
Dim Rng As Range
Dim NumberofCols As Long
Set ws = ThisWorkbook.Sheets("Sheet1") ' modify to your sheet's name
Set Rng = ws.Range("B1:B20")
' pass the following parameters:
' 1. Rng.column - in your case column B = 2
' 2. ws.Rows(1) - the Range to search for the Header, first row in ws worksheet
' 3. "Header" - the Header string you are searching for
NumberofCols = OffesttoHeader(Rng.Column, ws.Rows(1), "Header")
' raise an error message box
If NumberofCols = -10000 Then
MsgBox "Unable to find Header"
End If
End Sub
In order to obtain the solution you seek above, use the Range.Find Method.
'Column Number
Dim clmCountry as Integer
From here, we want to find the header by using the Range.Find Method
'to find the header
With ThisWorkbook.Sheets("SheetName")
'update the range if necessary
clmCountry = .Range("A1:Z1").Find("HeaderName").Column
End With
Once you've found the desired column, you may offset the following way:
... Offset(RowNum, clmCountry).Value = ...
I needed to get a column value out of a row defined as a Range.
Public Function ProcessOneLine(row As Range) As String
This works for me
row.Offset(0,2).Value2 ' returns the value in Column 3
row.Offset(1,Range("C1").Column).Value2 ' also returns the value in Column
So use something like this:
Dim srcColumn as String
Dim colPosn as Integer
srcColumn = "C"
colPosn = Range(srcColumn & "1").Column
cellValue = row.Offset(0,colPosn-1).Value2
Excel 2013
I have 3 worksheets in this workbook, its highly formatted and I used a custom formula I coded in VBA that utilizes Application.Volatile so it automatically refreshes the calculations every time you enter new data.
My team has formatted this workbook up and down and created a huge tracker that contains financials for our company. The problem is that now when we go to open the workbook and hit f9/load the calculate sheet function, only the selected worksheet will update and calculate based on its reference cells within that sheet.
It's supposed to do this, but the problem is inside of the other two tabs(mind you there are 3 total), the cells that have formulas will revert back to either all zeros or old data that is currently not applicable. When you select one of the other two tabs that initially were not selected and hit f9/load calculate sheet function the cells with functions that once had the zeros/old data inside them update based on the new values that the cell is referencing, and it works fine.
It keeps doing this as we switch tabs and reinitialize the f9/calculate sheet function, the other two tabs that are currently not selected reset and display either all zeros or old data. I have been googling and looking everywhere for a solutions and nothing has worked.
Function RedFinder(MyCellColumn As Integer, MyOffset As Integer, MonthCheck As Integer, YearCheck As Integer)
Application.Volatile
' Dim MyCellRow As Integer 'row I want to select
Dim MyMoneyValue As Variant 'Single holds a decimal variable
Dim MyAnswerString As String
' Sheets("Sheet1").Activate 'activate sheet1 at cell script runs on
' MyCellRow = 115 'set variable MyCellRow to row 1
MyMoneyValue = CDec("0.0")
' ActiveSheet.Cells(MyCellRow, MyCellColumn).Select 'select active cell based on input vars
For MyCellRow = 2 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row 'for loop used to go through all cells
If IsDate(ActiveSheet.Cells(MyCellRow, MyCellColumn)) Then 'checks if cell is a date
If Month(ActiveSheet.Cells(MyCellRow, MyCellColumn)) = MonthCheck And Year(ActiveSheet.Cells(MyCellRow, MyCellColumn)) = YearCheck Then 'checks if month and date match
If IsNumeric(ActiveSheet.Cells(MyCellRow, MyCellColumn).Offset(0, MyOffset)) Then 'checks if corresponding column is a number
If ActiveSheet.Cells(MyCellRow, MyCellColumn).Offset(0, MyOffset).Font.Color = 255 Then 'checks if cell text color is red, 255 is the number Font.Color returns for RGB Red (255,0,0)
MyMoneyValue = MyMoneyValue + ActiveSheet.Cells(MyCellRow, MyCellColumn).Offset(0, MyOffset) 'adds cell value to MyMoneyValue
' MyAnswerString = MyMoneyValue
' MyCellRow = MyCellRow + 1
' Else
' MyCellRow = MyCellRow + 1
End If
End If
' Else
' MyAnswerString = "False"
' MyCellRow = MyCellRow + 1
End If
End If
Next MyCellRow
'MsgBox MyCellColumnA
'RedFinder = Year(ActiveSheet.Cells(MyCellRow, MyCellColumn))
RedFinder = MyMoneyValue 'sets function to report total of MyMoneyValue
End Function
You need to remove all of the ActiveSheet references and replace them with a reference to the sheet containing the formula which calls your UDF
Function RedFinder(MyCellColumn As Integer, MyOffset As Integer, MonthCheck As Integer, YearCheck As Integer)
Application.Volatile
Dim MyMoneyValue As Variant 'Single holds a decimal variable
Dim MyAnswerString As String
Dim sht As Worksheet, c As Range, MyCellRow As Long
Set sht = Application.Caller.Parent '<<<< or use Application.ThisCell.Parent
MyMoneyValue = CDec("0.0")
For MyCellRow = 2 To sht.Cells(Rows.Count, 1).End(xlUp).Row
Set c = sht.Cells(MyCellRow, MyCellColumn)
If IsDate(c.Value) Then
If Month(c.Value) = MonthCheck And Year(c.Value) = YearCheck Then 'checks if month and date match
If IsNumeric(c.Offset(0, MyOffset)) Then
If c.Offset(0, MyOffset).Font.Color = 255 Then
MyMoneyValue = MyMoneyValue + c.Offset(0, MyOffset)
End If
End If
End If
End If
Next MyCellRow
RedFinder = MyMoneyValue
End Function
I've got 2 very similar functions, that were working before I switched my code to the Option Explicit for debugging puposes (success !). Since then, the Max function does not work anymore and I can't elaborate the reason why and solve it as an xl vba perfect noob.
The Max function (does not work):
Function MaxAddress(The_Range) As Variant
' See http://support.microsoft.com/kb/139574
Dim MaxNum As Variant
Dim cell As Range
' Sets variable equal to maximum value in the input range.
MaxNum = Application.Max(The_Range)
' Loop to check each cell in the input range to see if equals the
' MaxNum variable.
For Each cell In The_Range
If cell.Value = MaxNum Then
' If the cell value equals the MaxNum variable it
' returns the address to the function and exits the loop.
MaxAddress = cell.Address
Exit For
End If
Next cell
End Function
The runtime error :
I receive "error 91" at the runtime, with the Xmax valuing : "Nothing"
Error 91 stands for : undefined object or With block variable
The min function (works)
Function MinAddress(The_Range) As Variant
' See http://support.microsoft.com/kb/139574
Dim MinNum As Variant
Dim cell As Range
' Sets variable equal to maximum value in the input range.
MinNum = Application.Min(The_Range)
' Loop to check each cell in the input range to see if equals the
' MaxNum variable.
For Each cell In The_Range
If cell.Value = MinNum Then
' If the cell value equals the MaxNum variable it
' returns the address to the function and exits the loop.
MinAddress = cell.Address
Exit For
End If
Next cell
End Function
How I call both functions :
Set rng = ws_source.Range("3:3")
X_min = MinAddress(rng)
X_max = MaxAddress(rng) ' returns : X_max = Nothing
The data are in the row 3, containing formatted numbers and text.
(not an answer but too big for a comment)
I have the following in a normal module and it works fine:
Function MaxAddress(The_Range) As Variant
' See http://support.microsoft.com/kb/139574
Dim MaxNum As Variant
Dim cell As Range
' Sets variable equal to maximum value in the input range.
MaxNum = Application.Max(The_Range)
' Loop to check each cell in the input range to see if equals the
' MaxNum variable.
For Each cell In The_Range
If cell.Value = MaxNum Then
' If the cell value equals the MaxNum variable it
' returns the address to the function and exits the loop.
MaxAddress = cell.Address
Exit For
End If
Next cell
End Function
Sub xxx()
Dim rng As Range
Dim X_max As String
Set rng = ThisWorkbook.Sheets(1).Range("3:3")
X_max = MaxAddress(rng)
MsgBox (X_max)
End Sub
Not sure why min works, but I believe it's supposed to be
Application.WorksheetFunction.Max
&
Application.WorksheetFunction.Min