VBA code to get week number from given date - vba

I am working with Excel 2010.
I wish to convert a given date from the format mm/dd/yyyy to the format Wyy"weeknumber"
For example, 4/10/2017 would become W1715, since it is week 15 of 2017.
The below shown image is of the excel table I am working on. I want to convert the dates in column LT Verification - Planned Date to the week number format mentioned above, in column LT Verification - Planned Week Numbers.
Edit: Because this is part of a larger VBA process, I need it to be in VBA, not a cell formula.
I have written the following code:
Public Sub WeekNumbers()
Dim lastRow As Integer
lastRow = Range("A1:AZ1").Find("*", , , , xlByRows, xlPrevious).Row
Dim myRange As Range
Set myRange = Range("A1:AZ1" & lastRow)
Dim myCell As Range
For Each myCell In myRange
myCell.Offset(0, 1).Value = "W" & Right(Year(myCell.Value), 2) & Application.WorksheetFunction.WeekNum(myCell.Value)**
Next myCell
End Sub
This code gives me error at myCell.Offset(0, 1).Value = "W" & Right(Year(myCell.Value), 2) & Application.WorksheetFunction.WeekNum(myCell.Value)
Here I have a excel workbook which will be updated every week. So, each time it is updated, it runs a macro to import data from another file & perform the week number activity & create a pivot table.
So, the sheet name changes every week. Also, the column headers may be in different columns in different weeks. Also, the number of rows may also change every week.
So, I need to specify column & row range dynamically based on that weeks data.
And have the week numbers in the column based on the column header rather than the column name (A or B or Z...)

This can be achieved easily with a cell formula:
="W" & RIGHT(YEAR(A1),2) & WEEKNUM(A1)
Where A1 can be replaced by the cell containing the date.
In VBA this is equivalent to
With Thisworkbook.Sheets("Sheet1")
.Range("A2").Value = "W" & Right(Year(.Range("A1").Value), 2) & Application.WorksheetFunction.WeekNum(.Range("A1").Value)
End With
Edit:
To fill an entire range, you could loop over the cells, apply the VBA calculation as above.
Dim myRange as Range
Set myRange = Thisworkbook.Sheets("Sheet1").Range("A1:A10")
Dim myCell as Range
For Each myCell in myRange
myCell.Offset(0,1).Value = "W" & Right(Year(myCell.Value), 2) & Application.WorksheetFunction.WeekNum(myCell.Value)
Next myCell
There are many methods for finding the last row in a range, so I'll leave that to you if you don't know your range.
Edit 2: in response to your error edit.
You have used the following line to define your range:
Set myRange = Range("A1:AZ1" & lastRow)
Let's imaging you have lastRow = 20, you now have
myRange.Address = "A1:AZ120"
Which is clearly wrong, you shouldn't have the 1 after the AZ. Also I don't know why you've gone to column AZ, if all of your date data is in column A, you should use
Set myRange = Range("A1:A" & lastRow)
The loop you've implemented uses an offset, so the values in column B are changed to reflect those in column A. You can't then set column C according to column B!

In VBA, you can get your string by using the Format function. "\Wyyww" is the format you are looking for, where \ is used to escape the interpretation of the first W character and to take it as a litteral.
myCell.Offset(0,1).Value = Format(myCell.Value, "\Wyyww")
More
You have to setup correctly the range for your loop. If your dates are in some column with header "LT Verificiation - Planned Date", you can try this:
Dim ws As Worksheet
Set ws = ActiveSheet ' <-- you can change this into something explicit like Sheets(someIndex)...
Dim myCell As Range
Set myCell = ws.Rows(1).Find("LT Verificiation - Planned Date")
For Each myCell In ws.Range(myCell.Offset(1), ws.Cells(ws.Rows.Count, myCell.Column).End(xlUp))
If IsDate(myCell.value) Then myCell.Offset(, 1).value = Format(myCell.value, "\Wyyww")
Next myCell

I don't think you need VBA for this, try this formula:
=RIGHT(YEAR(A1),2)&WEEKNUM(A1)&"W"
Of course, if you insist on VBA, you can always turn Excel Formulas into VBA code. In this case:
Dim rngInput As Range
Dim rngOutput As Range
With Application.WorksheetFunction
rngOutput.Value = .Right(.Year(rngInput.Value), 2) & .Weeknum(rngInput.Value) & "W"
End With
Or you may even set the Formula, and Insert the Value, like this
Dim rngInput As Range
Dim rngOutput As Range
rngOutput.Formula = "=RIGHT(YEAR(" & rngInput.Address(False, False) & "),2)&WEEKNUM(" & rngInput.Address(False, False) & ")&""W"""
rngOutput.Value = rngOutput.Value

Related

Replace cell references with string from a corresponding cell

I have cells with calculations.
Here is one simple example, which is in row 11.
=$V11*$AB11*AF11
I'm trying to get this:
=[EAD: On Balance Sheet]*[PD Low]*[Collateral LGD High]
These 3 strings all come from row 10, in Column V, AB, and AF.
Here is another example:
Change this:
=$V11*VLOOKUP($AA11,Rates!AQ:AU,5,FALSE)*AE11
To this:
'[EAD: On Balance Sheet]*VLOOKUP([Proposed Risk Rating],Rates!AQ:AU,5,FALSE)*[Collateral LGD Low]
All formulas are on row 11, and I want to get the corresponding headers, which are all strings, from row 10.
I'm thinking that there must be a way to do this, since Excel knows all the relevant cell references, and keeps track of everything.
I can't figure out how to replace the reference with the string (in this case the corresponding header in row 10).
I'm pretty new to this so don't have enough 'reputation' to comment and clarify your question.
If the cells V11, AB11 and AF11 have the text "EAD: On Balance Sheet", "PD Low " and "Collateral LGD High" and you want this cell to show those words.
Then the following code could work:
sub combine_words()
dim i as string
dim j as string
dim k as string
i = range("V11").value
j = range("AB11").value
k = range("AF11").value
range("A11").value = "[" & i & "]*[" & j & "]*[" & k & "]"
end sub
replace the cell A11 with whichever cell you wanted the text inputed into.
Let me know if I understood your question incorrectly and I will change the code to match your needs if I can.
Perhaps a simple find and replace in the formula would work well enough. I'm sure there are lots of edge cases I'm not thinking about. Hopefully this steers the conversation in the right direction.
Sub SOExample()
Dim mySheet As Worksheet: Set mySheet = ThisWorkbook.Sheets("Sheet1")
Dim headerRng As Range: Set headerRng = mySheet.Range("A1:J1") 'Specify where to do replacements
Dim mycell As Range
Dim vkey As Variant
Dim myDict As Object: Set myDict = CreateObject("Scripting.Dictionary")
'Iterate each header row add the address as the key, and the NEXT row's Text as the value
For Each mycell In headerRng
If Not myDict.exists(mycell.Offset(1, 0).Address) Then
myDict.Add mycell.Offset(1, 0).Address, mycell.Text
End If
Next
'Iterate each cells formula and replace it
For Each mycell In headerRng
For Each vkey In myDict.keys
mycell.Offset(1, 0).Formula = Replace(mycell.Offset(1, 0).Formula, vkey, myDict(vkey), , , vbTextCompare)
Next
Next
End Sub

VBA Macro - I want to change each cell value to a new one in a specific range... how to do it? Excel

I have a range that is B3:B500
I want to change the value in each cell in that range
The range however, is dynamic so I need to look from B3 to last row
First:
How do I get it to change the range to work to last row rather than preset range?
Second:
I want to change each individual cell value to something like this:
myCell.Value = "=" & Chr(34) & Chr(61) & myCell.Value & Chr(34)
How do I get it to go through cell by cell to make change to each cell in the "dynamic" range we just created?
Appreciate all the help I can get... pretty new at VBA so please bear that in mind and keep it simple :)
I.e. Cell b3 contains: "ASP" (Text only)
Change to: ="="ASP" (formula instead giving result =ASP)
Dim lastRow As Integer: lastRow = 3
Dim myCell As Range
'determine last row of current region
Do While(Not IsEmpty(Cells(lastRow + 1, 2)))
lastRow = lastRow + 1
Loop
'loop through the range
For Each myCell In Range(Cells(2, 2), Cells(lastRow, 2))
myCell.Value = "=" & Chr(34) & Chr(61) & myCell.Value & Chr(34)
Next myCell
In this code, first you determine last row using While loop, which loops until the last row in column is found. Then use For Each loop, where you loop through the range, from third row to last row in B column.

Select & Copy Only Non Blank Cells in Excel VBA, Don't Overwrite

I cant seem to find a solution for my application after endless searching. This is what I want to do:
I have cells in one excel sheet that can contain a mixture of dates and empty cells in one column. I want to then select the cells that have only dates and then copy them to a corresponding column in another sheet. They must be pasted in exactly the same order as in the first sheet because there are titles attached to each row. I do get it right with this code:
'Dim i As Long
'For i = 5 To 25
'If Not IsEmpty(Sheets("RMDA").Range("D" & i)) Then _
Sheets("Overview").Range("D" & i) = Sheets("RMDA").Range("D" & i)
'Next i
However, the dates in the first sheet are being updated on a daily basis and it can be that one title has not been updated (on another day) on the first sheet because the user has not checked it yet. If I leave it blank and If I follow the same procedure then it will "overwrite" the date in the second sheet and make the cell blank, which I do not want. I hope I was clear. Can someone please help me?
Regards
You can accomplish this very easily (and with little code) utilizing Excel's built-in AutoFilter and SpecialCells methods.
With Sheets("RMDA").Range("D4:D25")
.AutoFilter 1, "<>"
Dim cel as Range
For Each cel In .SpecialCells(xlCellTypeVisible)
Sheets("Overview").Range("D" & cel.Row).Value = cel.Value
Next
.AutoFilter
End With
you could try something like. This will give you the non blanks from the range, there may be an easier way... hope it helps
Sub x()
Dim rStart As Excel.Range
Dim rBlanks As Excel.Range
Set rStart = ActiveSheet.Range("d1:d30")
Set rBlanks = rStart.SpecialCells(xlCellTypeBlanks)
Dim rFind As Excel.Range
Dim i As Integer
Dim rNonBlanks As Excel.Range
For i = 1 To rStart.Cells.Count
Set rFind = Intersect(rStart.Cells(i), rBlanks)
If Not rFind Is Nothing Then
If rNonBlanks Is Nothing Then
Set rNonBlanks = rFind
Else
Set rNonBlanks = Union(rNonBlanks, rFind)
End If
End If
Next i
End Sub
Just because a cell is blank does not mean that it is actually empty.
Based on your description of the problem I would guess that the cells are not actually empty and that is why blank cells are being copied into the second sheet.
Rather than using the "IsEmpty" function I would count the length of the cell and only copy those which have a length greater than zero
Dim i As Long
For i = 5 To 25
If Len(Trim((Sheets("RMDA").Range("A" & i)))) > 0 Then _
Sheets("Overview").Range("D" & i) = Sheets("RMDA").Range("D" & i)
Next i
Trim removes all spaces from the cell and then Len counts the length of the string in the cell. If this value is greater than zero it is not a blank cell and therefore should be copied.

Select sheet defined as date

I do have a workbook where multiple sheets are named based on date (in format MMDDD). This macro should loop trough all date sheet (like 01OCT, 02OCT, .... 30OCT) select range and copy it into new sheet.
Selecting cells, copying them and so is not really problem, and that is working perfectly. However I do have a problem defining sheet name. I would like user in the beginning define month and number of days in month and month using InputBox.
So if user select month = "FEB" and DaysMonth = 28, I would like macro to loop trough sheets named 01FEB, 02FEB, 03FEB, .... 28FEB.
Sub Merge_whole_month()
Application.ScreenUpdating = False
Dim month As String
month = InputBox(Prompt:="Please enter month in format MMM", _
Title:="Month")
Dim DaysMonth As Long
DaysMonth = InputBox(Prompt:="Please enter number of days in month", _
Title:="Days")
'create new sheet for results
Sheets.Add.Name = "Merge"
'loop
For i = 1 To DaysMonth
i = Format(i, "##")
Sheets(i & month).Activate 'here is the problem
'select cell G3, then all "non-empty" cells to the right and down and COPY
Range(Range("G3", Range("G3").End(xlToRight)), Range("G3", Range("G3").End(xlToRight)).End(xlDown)).Select
Selection.Copy
Sheets("Merge").Activate 'activate sheet where cells needs to be copied
'find last cell in 2nd row in sheet
lastCol = Cells(2, Columns.Count).End(xlToLeft).Column
lastCol = lastCol + 1
Cells(1, lastCol) = i & month 'log date and month in cell above
Cells(2, lastCol).Select
ActiveSheet.Paste 'Paste
Next i
Application.ScreenUpdating = True
End Sub
Many thanks in advance for any help!
The problem lies in the facto that i = Format(i, "##") does not make i less than 10 appear as 01 etc. To fix this i would do this:
Dim sDate As String
sDate = CStr(i)
If Len(sDate) < 2 Then
sDate = "0" & sDate
End If
Place that code within your for-loop before Sheets(i & month).Activate and remove i = Format(i, "##").
EDIT:
It also seems that for me using Format(i, "0#") gives the string you were looking for. However you will still need to assign this to a String variable or change Sheets(i & month).Activate to Sheets(Format(i, "0#") & month).Activate.
Here is the documentation on the Format() function. I suggest reading it.

Excel VBA for loop a Named List

I have a spreadsheet with a column of data day of the week and using a macro to execute a VBA. Column A is the day of the week and Column B is the name of the object. When I run the macro, it runs a For loop through a Named List and will populate the items in a calendar on another sheet. The macro works fine as long as I have the Named List in a fixed length (ie $L2:$A14) so if I add new data, I would need to fix the Named List.
Sub UpdateCalendar()
i = 2
Dim strRngName As String
lngLast = Sheets("Servers").Range("B" & Rows.Count).End(xlUp).Row
For Each c In Application.Range("ScheduledDates")
strRngName = c.Text
strUser = c.Offset(0, -1).Value
User = c.Offset(0, -10).Value
If (i > 45) Then
<code stuff>
i = i + 1
Next
End Sub
I tried switching line 5 to something like this:
For Each c In Sheets("Servers").Range("L" & Rows.Count).End(x1Up).Row
but it doesn't like that (I'm guessing it doesn't see it as a full array?). The problem with the way this executes is if the "ScheduledDates" field is blank, it will throw an error and stop the script, thus I'm using a fixed length in my Named List. Not sure if there's any way around this.
First, dim c as range, then update your code to:
For Each c In Sheets("Servers").Range("L2:L" & Sheets("Servers").cells(Rows.Count,"L").End(xlUp).Row).cells
or
dim c as range, lLastRow as long
lLastRow=Sheets("Servers").cells(Rows.Count,"L").End(xlUp).Row
For Each c In Sheets("Servers").Range("L2:L" & lLastRow).cells
You can also update the definition of your named range so it becomes a dynamic named range, either using an =offset( / counta structure, of by referencing a listObject
Assuming that column B always has an entry, I prefer this approach:
Sub UpdateCalendar()
Dim rng as Range
Dim strRngName As String
Set rng as Sheets("Servers").Range("B2")
While rng <> ""
strRngName = rng.Text
strUser = rng.Offset(0, -1).Value
'!!!Below line will cause an error in your code as B2 offset by -10 would be B-8!!!
User = rng.Offset(0, -10).Value
If (rng.Row > 45) Then
'<code stuff>
Set rng = rng.Offset(1)
Wend
End Sub
You can use your original code by making the named range dynamic.
For Example, entering the below formula in the 'Refers To' field of the named range selects a range from A2:C where is the row number of the last filled row.
=OFFSET(Sheet1!$A$1,1,0,COUNTA(Sheet1!$A:$A)-1,3)
(assuming data extends from col A to col C with headers in row1)