[英]Convert and separate date to Year/Month/Week Number
我有一系列日期。 我想将这些日期的年、月和周数分成不同的列。
我有以下代码,逐个单元格地计算它们:
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
有时最后一行超过 1000 行,这需要太多时间。
我怎样才能改进这个可以在更短的时间内运行的代码?
我有一个想法,虽然我不完全确定它是否有效。
将 Lastrow 分成 8 份(或更少)。 运行 8 个单独的循环,并让它们全部由一个子调用,以便它们同时运行。 您编码一次,然后将代码复制粘贴到 8 个不同的模块中。 Vba 是单线程的,但有些用户说如果 subs 位于不同的模块中,则 subs 可以同时运行。 所以基本上一个会运行 1 到 125,另一个运行 126 到 250 等等。
我从来没有尝试过,所以我不知道它是否有效。
一些使它更快的建议:
1.- 仅当您的表少于 32,000 行时,您才可以使用integers
(变量存储为 16 位(2 字节))而不是long
整数(变量存储为 32 位(4 字节))。
2.-关闭不必要的应用程序。
3.- 避免使用你并不真正需要的函数,比如Rows.Count
4.- 使用with
语句。
尝试这个:
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
如果您有兴趣,这里有一个完全不循环的版本(应该是最快的):
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.