Convert and separate date to Year/Month/Week Number

Question

I have a range of dates. I would like to separate, year, month and week number of those dates into different columns.
I have the following code, calculating them cell by cell:

Sub Sortdata()
    Dim WBData As Workbook
    Dim Lastrow As Long
    Dim j as long
    Dim D as Date
    
    Set WBData = ThisWorkbook
    Lastrow = WBData.Sheets("CDR").Cells(Rows.Count, "A").End(xlUp).row
    
    For j = 2 To Lastrow
        D = WBData.Sheets("CDR").Cells(j, 5) 'date 
        
        WBData.Sheets("CDR").Cells(j, 19) = Year(D)
        WBData.Sheets("CDR").Cells(j, 20) = Month(D)
        WBData.Sheets("CDR").Cells(j, 21) = Application.WorksheetFunction.WeekNum(D)
    Next j
End Sub

Sometimes the last row is over 1000 rows and it takes too much time.

How can I improve this code that it can run in a shorter time?

Answer 1

I have an idea though Im not entirely sure it works.

Split Lastrow into 8 parts (or less). Have 8 Separate loops run and have them all called by one single sub so they run simultaneously. You code it one time and then copy paste the code into 8 different modules. Vba is single threaded but some user said subs can run simultaneously if the subs are in different modules. So basically one would run 1 to 125 the other 126 to 250 etc.

Ive never tried it so i dont know if it works.

Answer 2

Some suggestions to make it faster:

1.- You can use integers (variables are stored as 16-bit (2-byte)) instead of long (variables are stored as 32-bit (4-byte)) only if your tables are shorter than 32 thousand rows.

2.- Turn off unnecessary applications.

3.- Avoid using functions you don't really need, like Rows.Count

4.- Use the with statement.

Try this:

Sub Sortdata()

'turn off unnecessary applications
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
   
Dim WBData As Workbook
Dim Lastrow As Integer
Dim j As Integer
Dim D As Date

Set WBData = ThisWorkbook
Lastrow = WBData.Sheets("CDR").Cells(1048576, 5).End(xlUp).Row

 For j = 2 To Lastrow
     
     D = WBData.Sheets("CDR").Cells(j, 5) 'date
     
     With WBData.Sheets("CDR")
         .Cells(j, 19) = Year(D)
         .Cells(j, 20) = Month(D)
         .Cells(j, 21) = WorksheetFunction.WeekNum(D)
     End With
     
 Next j

'remember to turn applications back on..
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
    
End Sub

Answer 3

If you're interested, here is a version that doesn't loop at all (which should be the fastest):

Sub Macro1()
Dim Lastrow As Long
Dim WBData As Workbook

Set WBData = ThisWorkbook

With WBData.Sheets("CDR")
    Lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
    Range(.Cells(2, 19), .Cells(Lastrow, 19)).Formula = "=Year(E2)"
    Range(.Cells(2, 20), .Cells(Lastrow, 20)).Formula = "=Month(E2)"
    Range(.Cells(2, 21), .Cells(Lastrow, 21)).Formula = "=WeekNum(E2)"
    Range(.Cells(2, 19), .Cells(Lastrow, 21)).Value = Range(.Cells(2, 19), .Cells(Lastrow, 21)).Value
End With

End Sub