优化代码以最小化宏的运行时间 [英] Optimize code to minimize runtime of the macro

问题描述

我一直在写一些宏来执行一些星象计算（计算标志，月球豪宅，D9和D60）。原始数据采用以下格式：

lng在上述图像中代表以度，分，秒格式表示的经度。输出必须采用以下格式：

我已经打了下面的代码，从输入表中读取数据，将其复制到输出表，然后用每个行星的经度计算所需的字段。

  Sub prepareOutput（）
 Application.ScreenUpdating = False 
 Dim c，count，d，l，ll 
 Dim r As Range 
 Set r = Worksheets（Ephemerides）。Range（a4：& ;工作表（Ephemerides）。Range（a4）。End（xlDown）.Address）
工作表（output）。Range（a3）。Value =Date
每个d在r 
工作表（输出）。单元格（d.Row，1）.Value = d.Value 
下一个
 
对于每个c在Worksheets（Ephemerides ）.Range（d2：o2）
如果不是IsEmpty（c）然后
 count = count + 5 
'MsgBox计数
如果count = 5然后
工作表（output）。单元格（2，2）.Value = c.Value 
工作表（output）。单元格（3，2）.Value =经度
工作表输出）单元格（3，3）.Value =Sign
工作表（output）。单元格（3，4）.Value =Nakshatra
工作表（o utts）。单元格（3，5）.Value =Navamsa
工作表（output）。单元格（3,6）.Value =D60
对于每个l在Worksheets Ephemerides）。Range（c.Offset（2，0），c.End（xlDown）.Address）
 Worksheets（output）。Cells（l.Row，2）.Value = l.Value 
工作表（output）。单元格（l.Row，3）.Value = calcSign（l.Value）
下一个
 count = 2 
 Else 
工作表（ 输出）单元格（2，计数）.Value = c.Value 
工作表（输出）单元格（3，计数）.Value =经度
工作表（输出 .Cells（3，count + 1）.Value =Sign
 Worksheets（output）。Cells（3，count + 2）.Value =Nakshatra
 Worksheets（output .Cells（3，count + 3）.Value =Navamsa
 Worksheets（output）。Cells（3，count + 4）.Value =D60
 For each ll In Worksheets Ephemerides）。范围（c.Offset（2，0），c.End（xlDown）.Address）
工作单元格（ll.Row，count）.Value = ll.Value 
工作表（output）。单元格（ll.Row，count + 1）.Value = calcSign（ll.Value ）
下一个
如果
结束If 
 Next 
 Application.ScreenUpdating = True 
 End Sub 
 
 
 
私有函数deg2dec（deg As String）As Variant 
d = Val（Mid（deg，1，InStr（deg，°） -  1））
m = Val（Mid（deg， InStr（deg，°）+ 1，2））/ 100 
 deg2dec = d + m 
结束函数
 
 
私有函数calcSign（deg As String ）As String 
 dec = deg2dec（deg）
选择案例dec 
案例0到30 
 calcSign =白羊座
案例30到60 
 calcSign =金牛座
案例60到90 
 calcSign =Gemini
案例90到120 
 calcSign =癌症
案例120到150 
 calcSign =Leo
案例150到180 
 calcSign =处女座
案例180到210 
 calcSign =Libra
 Ca se 210到240 
 calcSign =天蝎座
案例240到270 
 calcSign =Saggitarius
案例270到300 
 calcSign =摩羯座
案例300到330 
 calcSign =Aquarius
案例330到360 
 calcSign =双鱼座
结束选择
结束功能
  

上面的代码不会计算所有4个计算字段，现在只有一个。

$ b $我遇到的问题是我的输入表中有24000行和12列，并且花费大量的时间将这些数据复制到输出表，然后对其进行计算以再计算一个值。我必须从一个经度值中再计算3个字段。

所以，如果你们可以看看代码，让我知道我能如何去最小化这里的运行时，这将有助于很多。

如果有人想看看，这里是工作簿的链接。 astro.xlsm

提前感谢所有花时间回复的人。

干杯

解决方案

有几件事你可以做。首先，声明所有变量节省内存，从而节省时间。话虽如此，代码中的实时消耗因素是每个单元格的循环。获得相同结果的最快方法是将数据读入数组，然后将数组写入输出表。在下面的代码中，我已经以这样的方式编辑了您的 prepareOutput sub，它保留了您的初始代码结构，而不是循环并写入每个单元格，现在将数据读入数组，然后将该数组写入所需的输出区域。

  Sub prepareOutput（）
应用程序.ScreenUpdating = False 
 Dim c As Range，d As Range，l As Range，ll As Range，r As Range 
 Dim count As Integer 
 Dim ArrDim As Integer，CurrVal As Integer 
 Dim OutRng As Range 
 Dim TempArr（）As String 
 
'定义工作表
 Dim WsEmph As Worksheet，WsOut As Worksheet 
设置WsEmph = ActiveWorkbook.Sheets ephemerides）
设置WsOut = ActiveWorkbook.Sheets（Output）
 
设置r = WsEmph.Range（a4：& Worksheets（Ephemerides）。 a4）。End（xlDown）.Address）
 
 WsOut.Range（a3）。Value =Date
对于每个d在r 
 WsOut.Cells d.Row， 1）.Value = d.Value 
 Next 
 
对于每个c在WsEmph.Range（d2：o2）
如果不是IsEmpty（c）然后
 count = count + 5 
 
'临时数组的重定向
 ArrDim = WsEmph.Range（c.Offset（2，0），c.End（xlDown））。Rows.count 
 ReDim TempArr（1到ArrDim，1到2）
 CurrVal = 1 
 
如果count = 5然后
用WsOut 
 .Cells（2，2） .Value = c.Value 
 .Cells（3，2）.Value =Longitude
 .Cells（3，3）.Value =Sign
 .Cells（3,4 ）.Value =Nakshatra
 .Cells（3，5）.Value =Navamsa
 .Cells（3，6）.Value =D60
 End with 
 
对于每个l在WsEmph.Range（c.Offset（2，0），c.End（xlDown）.Address）
'填充数组
 TempArr（CurrVal，1）= l .Value 
 TempArr（CurrVal，2）= calcSign（l.Value）
 CurrVal = CurrVal + 1 
下一个
'设置输出范围并写入数据
 Set OutRng = WsOut.Range（WsOut .Cells（c.Offset（2，0）.Row，2），WsOut.Cells（c.End（xlDown）.Row，3））
 OutRng = TempArr 
 count = 2 
 Else 
 With WsOut 
 .Cells（2，count）.Value = c.Value 
 .Cells（3，count）.Value =Longitude
 .Cells（3 ，count + 1）.Value =Sign
 .Cells（3，count + 2）.Value =Nakshatra
 .Cells（3，count + 3）.Value =Navamsa
 .Cells（3，count + 4）.Value =D60
结束
 
对于每个ll在WsEmph.Range（c.Offset（2，0），c .End（xlDown）.Address）
'填充数组
 TempArr（CurrVal，1）= ll.Value 
 TempArr（CurrVal，2）= calcSign（ll.Value）
 CurrVal = CurrVal + 1 
下一个
'设置输出范围和写数据
 Set OutRng = WsOut.Range（WsOut.Cells（c.Offset（2，0）.Row，count），WsOut.Cells（c.End（xlDown）.Row，count + 1））
 OutRng = TempArr 
 End If 
 End If 
 Next 
 Application.ScreenUpdating = True 
 End Sub 
  / pre> 
 
 
在我的系统上运行你的代码  25.16秒 。通过对代码的上述更改，现在只需执行  3.16秒 来执行相同的任务。 
 
 
 
请注意，我还声明了所有变量，并使用工作表变量作为每个工作表的依赖。尽管后者并没有提高速度，但它只是提高了代码的可读性。 
 
I have been writing some macros to perform some astrological calculations (calculating sign, lunar mansion, D9 & D60). The raw data is in the following format:



lng in the above image stands for longitude expressed in degree,minute,second format. The output has to be in the following format:



I have whipped up the following code to read the data from the input sheet and format & copy it to the output sheet then do calculations with the longitude of each planet to calculate required fields.
Sub prepareOutput()
Application.ScreenUpdating = False
Dim c, count, d, l, ll
Dim r As Range
Set r = Worksheets("Ephemerides").Range("a4:" & Worksheets("Ephemerides").Range("a4").End(xlDown).Address)
Worksheets("output").Range("a3").Value = "Date"
For Each d In r
    Worksheets("output").Cells(d.Row, 1).Value = d.Value
Next

For Each c In Worksheets("Ephemerides").Range("d2:o2")
    If Not IsEmpty(c) Then
        count = count + 5
        'MsgBox count
        If count = 5 Then
            Worksheets("output").Cells(2, 2).Value = c.Value
            Worksheets("output").Cells(3, 2).Value = "Longitude"
            Worksheets("output").Cells(3, 3).Value = "Sign"
            Worksheets("output").Cells(3, 4).Value = "Nakshatra"
            Worksheets("output").Cells(3, 5).Value = "Navamsa"
            Worksheets("output").Cells(3, 6).Value = "D60"
            For Each l In Worksheets("Ephemerides").Range(c.Offset(2, 0), c.End(xlDown).Address)
                Worksheets("output").Cells(l.Row, 2).Value = l.Value
                Worksheets("output").Cells(l.Row, 3).Value = calcSign(l.Value)
            Next
            count = 2
        Else
            Worksheets("output").Cells(2, count).Value = c.Value
            Worksheets("output").Cells(3, count).Value = "Longitude"
            Worksheets("output").Cells(3, count + 1).Value = "Sign"
            Worksheets("output").Cells(3, count + 2).Value = "Nakshatra"
            Worksheets("output").Cells(3, count + 3).Value = "Navamsa"
            Worksheets("output").Cells(3, count + 4).Value = "D60"
            For Each ll In Worksheets("Ephemerides").Range(c.Offset(2, 0), c.End(xlDown).Address)
                Worksheets("output").Cells(ll.Row, count).Value = ll.Value
                Worksheets("output").Cells(ll.Row, count + 1).Value = calcSign(ll.Value)
            Next
        End If
    End If
Next
Application.ScreenUpdating = True
End Sub



Private Function deg2dec(deg As String) As Variant
d = Val(Mid(deg, 1, InStr(deg, "°") - 1))
m = Val(Mid(deg, InStr(deg, "°") + 1, 2)) / 100
deg2dec = d + m
End Function


Private Function calcSign(deg As String) As String
dec = deg2dec(deg)
Select Case dec
    Case 0 To 30
        calcSign = "Aries"
    Case 30 To 60
        calcSign = "Taurus"
    Case 60 To 90
        calcSign = "Gemini"
    Case 90 To 120
        calcSign = "Cancer"
    Case 120 To 150
        calcSign = "Leo"
    Case 150 To 180
        calcSign = "Virgo"
    Case 180 To 210
        calcSign = "Libra"
    Case 210 To 240
        calcSign = "Scorpio"
    Case 240 To 270
        calcSign = "Saggitarius"
    Case 270 To 300
        calcSign = "Capricorn"
    Case 300 To 330
        calcSign = "Aquarius"
    Case 330 To 360
        calcSign = "Pisces"
End Select
End Function
The above code doesn't calculate all 4 computed fields, just one for now.

The problem I am having is that I have 24000 rows and 12 columns in my input sheet and it is taking a lot of time to just copy this data to the output sheet and then doing calculations on it to compute one more value.And I have to calculate 3 more fields from one longitude value.

So if you guys could take a look at the code and let me know how i could go about minimizing the runtime here, that would help a lot.

Here's the link to the workbook if anyone wants to take a look. astro.xlsm

Thanks in advance to all those who take out time to reply.

Cheers
解决方案
There are a couple of things you can do. First of all, declaring all variable saves memory which in turn saves time. That being said, the real time consuming factor in your code is the looping through each cell. The fastest way to obtain the same result is to read the data into an array and then write the array to the output sheet. In the following code, I have edited your prepareOutput sub in such a way, that it keeps your initial code structure, but instead of looping through and writing to each cell, it now reads the data into an array and then writes this array to the desired output area.
Sub prepareOutput()
    Application.ScreenUpdating = False
    Dim c As Range, d As Range, l As Range, ll As Range, r As Range
    Dim count As Integer
    Dim ArrDim As Integer, CurrVal As Integer
    Dim OutRng As Range
    Dim TempArr() As String

    'Defines worksheets
    Dim WsEmph As Worksheet, WsOut As Worksheet
    Set WsEmph = ActiveWorkbook.Sheets("Ephemerides")
    Set WsOut = ActiveWorkbook.Sheets("Output")

    Set r = WsEmph.Range("a4:" & Worksheets("Ephemerides").Range("a4").End(xlDown).Address)

    WsOut.Range("a3").Value = "Date"
    For Each d In r
        WsOut.Cells(d.Row, 1).Value = d.Value
    Next

    For Each c In WsEmph.Range("d2:o2")
        If Not IsEmpty(c) Then
            count = count + 5

            'Redimension of temporary array
            ArrDim = WsEmph.Range(c.Offset(2, 0), c.End(xlDown)).Rows.count
            ReDim TempArr(1 To ArrDim, 1 To 2)
            CurrVal = 1

            If count = 5 Then
                With WsOut
                    .Cells(2, 2).Value = c.Value
                    .Cells(3, 2).Value = "Longitude"
                    .Cells(3, 3).Value = "Sign"
                    .Cells(3, 4).Value = "Nakshatra"
                    .Cells(3, 5).Value = "Navamsa"
                    .Cells(3, 6).Value = "D60"
                End With

                For Each l In WsEmph.Range(c.Offset(2, 0), c.End(xlDown).Address)
                    'Fills array
                    TempArr(CurrVal, 1) = l.Value
                    TempArr(CurrVal, 2) = calcSign(l.Value)
                    CurrVal = CurrVal + 1
                Next
                    'Sets output range and writes data
                    Set OutRng = WsOut.Range(WsOut.Cells(c.Offset(2, 0).Row, 2), WsOut.Cells(c.End(xlDown).Row, 3))
                    OutRng = TempArr
                    count = 2
            Else
                With WsOut
                    .Cells(2, count).Value = c.Value
                    .Cells(3, count).Value = "Longitude"
                    .Cells(3, count + 1).Value = "Sign"
                    .Cells(3, count + 2).Value = "Nakshatra"
                    .Cells(3, count + 3).Value = "Navamsa"
                    .Cells(3, count + 4).Value = "D60"
                End With

                For Each ll In WsEmph.Range(c.Offset(2, 0), c.End(xlDown).Address)
                    'Fills array
                    TempArr(CurrVal, 1) = ll.Value
                    TempArr(CurrVal, 2) = calcSign(ll.Value)
                    CurrVal = CurrVal + 1
                Next
                    'Sets output range and writes data
                    Set OutRng = WsOut.Range(WsOut.Cells(c.Offset(2, 0).Row, count), WsOut.Cells(c.End(xlDown).Row, count + 1))
                    OutRng = TempArr
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub
On my system, running your code took 25.16 seconds. With the above changes to the code it now takes just 3.16 seconds to perform the same task. 

Note that I have also declared all variables and used worksheet-variables as refference to each worksheet. All though the latter doesn't improve speed, it only improves the readability of the code. 

                        
这篇关于优化代码以最小化宏的运行时间的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！