I have to a point in my VBA venture where i cannot avoid using loops. This time I have to do it with an offset method as well. I have looked at other postings, but the code was very long and looked complicated enough that I couldn't figure out how to simplify them for my needs. I hope someone can assist me.
I have a table in excel and all of my columns in my table have a name (makes VBA easier in my opinion). I am trying to perform a worksheet_activiate trigger that will loop through each row in column C (named "recordstatus"). And if the cell value equals "in process", then look 5 columns over at Column I (named "DeliveryDueDate"). If delivery due date is less than newdate (newdate I have already defined in my code) then record status equals "Open", else keep it as "In Process".
Below is the code I have so far. I have tested the looping and the lopping works, but will set all records to "open" even if the delivery due date is greater than what I define in the code. I have also tested to make sure the code comes back with the correct date range and it does. The code just doesn't seem to recognize my offset to look at the date and determine if the record status should change or stay the same. Any help would be greatly appreciated. I am at the tail end of this project!!! :-)
Dim c As Range
For Each c In Range("recordstatus")
If c.Value = "In Process" Then
Dim today As Date
Dim newdate As Date
today = Now()
newdate = today + 60
If c.Offset(, 5) < newdate Then
MsgBox ("works")
c.Value = "Open"
Else
c.Value = "In Process"
End If
End If
Next
Utilize Named Range
One of the reasons of using named ranges is to avoid using the wrong ranges (columns).
The Code
Option Explicit
Sub updateProgress()
Dim src As Range
Set src = Range("DeliveryDueDate")
Dim tgt As Range
Set tgt = Range("recordstatus")
Dim today As Date
today = Now()
Dim newdate As Date
newdate = today + 60
Dim i As Long
For i = 1 To tgt.Cells.Count
If tgt.Cells(i).Value = "In Process" Then
If src.Cells(i) < newdate Then
MsgBox "works"
tgt.Cells(i).Value = "Open"
Else
tgt.Cells(i).Value = "In Process"
End If
End If
Next
End Sub
Related
At work we are using Office 365 Excel's file as a booking system. It has multiple tabs for each site where each record has a booking date. There is problem of date formatting - basically the default locale is set to "mm/dd/yyyy" however the date is displayed in "dd/mm/yyyy". When people add rows manually (normally booking slots are generated automatically for each day) and just type in date in a wrong format instead of copying date value from the adjacent cell it displays right, but the cell value in the top bar is different, but when opening this file in the Desktop App it does not see this as different values at all. Only when applying filter, there are dates, and string date values you can filter by. This causes some of the dates not being picked up by the macros while creating reports, or importing data based on the date.
I've been thinking of writing an utility macro that would sanitize all dates based on the dates up and down to the current date, however I am not sure if this is the best way to go. I don't think I can just change the locale settings for all users as for what I read in docs this will make changes only to the single user settings and I am not really sure how this will affect overall functionality of whole system. Is there any way it can be done rather more easily than parsing this massive file or manually finding this dates?
It is a real pain as this file was designed long time before I came to the team and now I am trying to make this less error prone.
Thanks for any clues in advance!
Real dates are numeric. So you can check with IsNumeric
If IsNumeric(Range("A1").Value2) Then
Debug.Print "date"
Else
Debug.Print "string"
End If
Note that you need to check .Value2 not .Value
Peh's answer guided me to the right solution. Here is the whole code if anyone would came across similar problem:
Sub SanitizeDates()
' ---
' Utility macro that goes over all live sheets and checks all rows
' for the string dates that have been input manually
' and converts it to an actual Date values.
' ---
Debug.Print "--- Log Start"
Dim Prompt As String
Dim Errors As Integer
Dim TotalErrors As Integer
TotalErrors = 0
Errors = 0
Dim Tracker As Workbook
Dim WS As Worksheet
Dim CurrentDateValue As Variant
Dim NewDate As Date
Dim RowCount As Long
Dim nRow As Long
Set Tracker = ThisWorkbook
Application.ScreenUpdating = False
For Each WS In Tracker.Worksheets
If WS.Visible And Not WS.Name = "Matrix" Then ' if worksheet is not visible and not a Matrix
If InStr(1, WS.Name, "Template", vbTextCompare) = 0 Then ' if worksheet is not a template
Errors = 0
RowCount = WS.ListObjects(1).DataBodyRange.Rows.Count
'loop over all rows in table
For nRow = 1 To RowCount
With WS.ListObjects(1).DataBodyRange
' check if the cell is a black bar / divider
If Not .Cells(nRow, 3).Interior.Color = RGB(0, 0, 0) Then
If Not IsNumeric(.Cells(nRow, 3).Value2) Then
On Error GoTo SkipInvalid
NewDate = DateValue(.Cells(nRow, 3).Value2)
.Cells(nRow, 3).Value2 = NewDate
Errors = Errors + 1
'Error logging
'Call LogError(.Cells(nRow, 5), .Cells(nRow, 15), "Date Format - dev")
End If
End If
End With
SkipInvalid:
Next nRow
TotalErrors = TotalErrors + Errors
If Errors Then
Prompt = Prompt & "Found " & Errors & " errors in " & WS.Name & vbCrLf
Debug.Print "Found " & Errors & " errors in " & WS.Name
End If
End If
End If
Next WS
Application.ScreenUpdating = True
Debug.Print "--- Log End"
If TotalErrors Then
MsgBox (Prompt & vbCrLf & vbCrLf & _
"Total of " & TotalErrors & " errors found. All data sanitized successfully.")
Else
MsgBox ("No errors found")
End If
End Sub
Looks like your problem derives from the fact people are entering invalid dates.
You may try to apply a data validation on the cells to sanitize during data entry.
Data validation allows to set a cell as Date and then you can specify a date range. So only valid dates within that range will be allowed.
I want to convert a date in a cell to the date function so it is a formula. How do I get the date (using VBA), any date, say, 13 Jun 2020 to =DATE(2020, 6, 13) using variables for the year, month, and day. My code I have tried but won't work. The activecell shows 13-Jun-2020 as a date but appears in the function box as 13/06/2020
Sub ConvertDateToDateFunction()
Dim mvDay, mvMth, mvYr As Integer
mvDay = Left(ActiveCell, 2)
mvMth = Mid(ActiveCell, 4, 2)
mvYr = Right(ActiveCell, 4)
ActiveCell.Value = "=DATE(mvYr, mvMth, mvDay)"
End Sub
You have two problems. Here is the solution to the smaller one. The code below would do what you intend. It would convert a text string in the ActiveCell to a function of similar value and insert it in the cell below the ActiveCell.
Sub ConvertDateToDateFunction()
' if you don't say what it's supposed to be it'll be a Variant
Dim mvDay As String, mvMth As String, mvYr As String
mvDay = Left(ActiveCell.Value, 2)
mvMth = Mid(ActiveCell.Value, 4, 2)
mvYr = Right(ActiveCell.Value, 4)
ActiveCell.Offset(1).Formula = "=DATE(" & mvYr & "," & mvMth & "," & mvDay & ")"
End Sub
It's not entirely easy to insert a date as a text string in Excel because Excel will try to recognize a date for a date. Observe that any part of a string is a string, not an integer.
Now about your much bigger problem which is that you don't understand how Excel handles dates. It is such a big problem because you are trying to create a date in Excel in various ways and you run into all sorts of trouble. Read up on the subject here.
To give you a taste of what you will learn: what you see displayed in a cell isn't what the cell contains. There might be a formula in it and you see a number. And there might be a date and you see a string. What you see is determined by the cell's format. I think Chip Pearson's article will cover that topic. If you need to know more, look for "Cell formatting" on the web.
Your macro won't work because the date is a "real date" and not a string.
Try the following to convert the contents of cells containing a real date to a formula which will return the same date:
Option Explicit
Sub dtToFormula()
Dim R As Range, C As Range
Dim vDateParts(2)
Set R = [a1:a10]
'Set R = ActiveCell 'or Selection whatever range you want to convert
For Each C In R
If IsDate(C) And Not C.HasFormula Then
vDateParts(0) = Year(C.Value2)
vDateParts(1) = Month(C.Value2)
vDateParts(2) = Day(C.Value2)
C.Formula = "=DATE(" & Join(vDateParts, ",") & ")"
End If
Next C
End Sub
I am new to coding and have written some code to do some calculations within a table and fill in columns. I have it working for the first row within the table but I am having some trouble figuring out how to loop it so that it completes the calculations for every row within the table. Any help and advice would be greatly appreciated!
UPDATE:
Thanks for the Help! The code works perfectly for the first part provided here, I have tried to apply this to the other 2 parts, but am coming up with an error. I think due to the fact that I am trying to use a string as the input? I have tried without the quotation marks but all it returns is "#NAME?".
Sub CommandButton1_Click()
Dim tbl As ListObject
Set tbl = ThisWorkbook.Sheets("Data").ListObjects("Table1")
Dim formulaText As String
formulaText =
"=IF([#Reach]>=100000,5,IF([#Reach]>=50000,3,IF([#Reach]>=10000,2,1)))"
tbl.ListColumns("Media Significance").DataBodyRange.Formula = formulaText
Dim formulaText1 As String
formulaText1 = "=IF([#Headline Mentions]>="Yes",5,IF([#Exclusive
Mentions]>="Yes",3,1))"
tbl.ListColumns("Prominence Score").DataBodyRange.Formula = formulaText1
Dim formulaText2 As String
formulaText2 = "=IF([#Sentiment]>="Very Positive",2,IF([#Sentiment]>="Very
Negative",2,1))"
tbl.ListColumns("Very Positive/ Very Negative").DataBodyRange.Formula =
formulaText2
End Sub
Looping through each cell in a range is very slow, so you're either going to want to either load your data into an array first, or use a regular Excel formula + the FillDown function.
In this particular case, I'd recommend the second option, which will allow you to add your formula to a single cell and fill it down the rest of the column. Something like this should work:
Dim colNum As Long
With ThisWorkbook.Sheets("Example Sheet")
'Find last row in sheet
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'Add first formula
colNum = .Range("V2").Column
.Cells(2, colNum).Formula = "=IF(T2>=100000,5,IF(T2>=50000,3,IF(T2>=10000,2,1)))"
.Range(.Cells(2, colNum), .Cells(lastRow, colNum)).FillDown
End With
One problem with your current code is that the column letters are hard-coded. IE, you're expecting to find something called "Reach" in column L, and assuming that this will always be the case. However, if you ever add another column to the left of "Reach", it will break your code.
That's one reason why I'd probably recommend turning your range into a table object with descriptive column names. That should make your code much easier to read and maintain, like this:
Dim tbl As ListObject
Set tbl = ThisWorkbook.Sheets("Example Sheet").ListObjects("YourTable")
Dim formulaText As String
formulaText = "=IF([#Reach]>=100000,5,IF([#Reach]>=50000,3,IF([#Reach]>=10000,2,1)))"
tbl.ListColumns("Reach Analysis").DataBodyRange.Formula = formulaText
For starters, you have redundant criteria in your first If/ElseIf/End If statement.
This,
If Reach >= 100000 Then
Result = 5
ElseIf Reach < 100000 And Reach >= 50000 Then
Result = 3
ElseIf Reach < 50000 And Reach >= 10000 Then
Result = 2
ElseIf Reach < 10000 Then
Result = 1
End If
... can be written more succinctly as,
If Reach >= 100000 Then
Result = 5
ElseIf Reach >= 50000 Then
Result = 3
ElseIf Reach >= 10000 Then
Result = 2
Else
Result = 1
End If
These If/ElseIf/Else/End If conditions are resolved sequentially. Since you won't get into the second criteria unless Reach is less than 100000, there is no need to put that specification into the second criteria. The same logic can be applied for the remainder of the conditions.
Your second If/ElseIf/End If has an error in syntax.
ElseIf Headline = "No" And Exclusive = Yes Then
The Yes here should be quoted or the condition will be looking for a variable named Yes. Putting Option Explicit at the top of the module code sheet in the Declarations area will catch these errors quickly. You can also access the VBE's Tools, Options command and put a checkmark beside Require Variable Declaration and Option Explicit will be automatically put into the Declaration area of each new code sheet you create.
I have a problem. I spent hours designing a form which works just great with all your feedback. Today, everything went wrong. The reason for this is simple. A few new columns got added and, obviously, the data my form is reading in is now wrong.
Thus I was thinking of trying the following...
Rather than using the column number as below
TK = Cells(ActiveCell.Row, "S").Value 'everything in the form refers to the active row
I could possibly use the column headings in Row 1.
Is that possible ? This way the spreadsheet can have columns added up to as many as a user would like and the form would dynamically scan for the right heading and get the column number that way.
My thought is, on opening the form, read in all the headings, pick out the ones I need and assign them to a variable. Then I use my normal code and substitute the variable into the column section.
It sounds easy, but I have no idea how to do this.
Use the versatile Find to give you a quick method of detecting where your header is - or if it is missing
Find details here
In the code below I have specified that the search must return
an exact match (xlWhole)
a case sensitive match (False)
The match can be a partial match (xlPart) if you were looking to match say Game out of Game X
code
Const strFind = "Game"
Sub GetEm()
Dim rng1 As Range
Set rng1 = ActiveSheet.Rows(1).Find(strFind, , xlValues, xlWhole, , , False)
If Not rng1 Is Nothing Then
MsgBox "Your column is " & rng1.Column
Else
MsgBox strFind & " not found", vbCritical
End If
End Sub
Why use a loop? There's no need to.
Dim col as variant
Col = application.match("my header", rows(1), 0)
If iserror(col) then
'not found
Else
TK = cells(activecell.row, col)
End if
For this purpose I usually use a function which runs through the headers (in the first row of a sheet) and returns the number of the column which contains the value I have searched for.
Public Function FindColumn(HeaderName As String, Sht As String) As Long
Dim ColFound As Boolean
Dim StartingPoint As Range
ColFound = False
Set StartingPoint = Sheets(Sht).Range("A1")
Do While StartingPoint.Value <> ""
If UCase(Trim(StartingPoint.Value)) = UCase(Trim(HeaderName)) Then
FindColumn = StartingPoint.Column
ColFound = True
Exit Do
Else
Set StartingPoint = StartingPoint.Offset(0, 1)
End If
Loop
If Not ColFound Then FindColumn = 0
End Function
Example:
If the first row of your sheet named "Timeline" contains headers like e.g. "Date" (A1), "Time" (B1), "Value" (C1) then calling FindColumn("Time", "Timeline") returns 2, since "Time" is the second column in sheet "Timeline"
Hope this may help you a little.
Your thought is a good one. Reading in column headers to calculate addresses is one way to avoid hard coding - e.g.
Sub Test()
Dim R As Range
Set R = ActiveSheet.[A1]
Debug.Print ColNo(R, "Col1Hdr")
End Sub
Function ColNo(HdrRange As Range, ColName As String) As Integer
' 1st column with empty header is returned if string not found
ColNo = 1
Do While HdrRange(1, ColNo) <> ""
If HdrRange(1, ColNo) = ColName Then Exit Do
ColNo = ColNo + 1
Loop
End Function
Another way I frequently use - and I must admit I prefer it over the above, is to define Enum's for all my tables in a seperate "definition" module, e.g.
Public Enum T_VPN ' sheet VPN
NofHRows = 3 ' number of header rows
NofCols = 35 ' number of columns
MaxData = 203 ' last row validated
GroupNo = 1
CtyCode = 2
Country = 3
MRegion = 4
PRegion = 5
City = 6
SiteType = 7
' ....
End Enum
and use it like
Sub Test1()
Debug.Print ActiveSheet(T_VPN.NofHRows, T_VPN.Country)
End Sub
As you can see, the usage is simpler. Allthough this is again "some kind" of hardcoding, having all definition in one place reduces maintenance significantly.
Sorry if this isn't explained overly well, im a macro newbie so im not sure if this one is even possible..
I'm looking to create a weekday table for some simple statistic reporting that automatically creates a new row each day, and removes the oldest, showing the data for the current day and 6 days previous. Ideally i'd like the current day at the top of the table, and each day the entered data in the corresponding row moves down 1 row creating space for the new day's stats.
As some background info on what im trying to do.. im basically creating a friendly UI display (offline HTML) of the data recorded in a very simple 5 column (stats) by 7 row (weekdays) table. This database will need to be updated by multiple people with limited technical ability, so im basically trying to make it as easy as possible for them to enter stats each day without having to worry about also updating to correct dates and making sure they are replacing the right days data etc. In theory, it would be great to automate the process of updating the table each day to create space for them to enter the current days data, pushing yesterdays data down one row (and if the cell ranges for the whole table always the same, it should allow me to automate the updates to the offline HTML display as well).
Any ideas?
This should get you started:
Sub WeekdayTable()
Dim tbl As Range
Dim r As Integer
Set tbl = Range("A1:E7") 'Define your table, 5 columns x 7 rows. Modify as needed.
For r = tbl.Rows.Count To 2 Step -1
tbl.Rows(r).Value = tbl.Rows(r - 1).Value
Next
'empty out row 1
tbl.Rows(1).Clear
'Assuming the column 1 contains valid DATE values, _
' we can use the DateAdd function to print the next date:
tbl.Cells(1, 1) = DateAdd("d", 1, tbl.Cells(2, 1))
End Sub
First give a name to the date header cell. (Click the cell. Look at the top left of the screen where the cell coordinates appear. "A1", "B2", etc...
In that textbox, type the header name: "MyDateHeader"
then, use this macro (you can add it to the workbook open event, or activate)
Sub YourMacro()
Dim DateHeader As Range
Set DateHeader = Range("MyDateHeader")
Dim FirstDateCell As Range
Set FirstDateCell = DateHeader.Offset(1, 0)
Dim MyDay As Integer, MyMonth As Integer, MyYear As Integer
Dim CurrDay As Integer, CurrMonth As Integer, CurrYear As Integer
MyDay = Day(FirstDateCell.Value)
MyMonth = Month(FirstDateCell.Value)
MyYear = Year(FirstDateCell.Value)
CurrDay = Day(Date)
CurrMonth = Month(Date)
CurrYear = Year(Date)
If (MyDay <> CurrDay) Or (MyMonth <> CurrMonth) Or (MyYear <> CurrYear) Then
FirstDateCell.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
DateHeader.Offset(1, 0).Value = Date 'Careful, FirstDateCell has moved down.
DateHeader.Offset(8, 0).EntireRow.Clear
End If
End Sub