Question

我一直在编写一些宏来执行一些占星计算（计算符号，月球大厦，D9和D60）。原始数据采用以下格式：

input data format

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

output data layout

我已经掀起了以下代码来读取输入表中的数据和格式＆amp;将其复制到输出表，然后用每个行星的经度进行计算，以计算所需的字段。

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

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

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

所以，如果你们可以看看这些代码并让我知道如何在这里尽量减少运行时间，那将会有很大的帮助。

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

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

干杯

Answer 1

以下提示会对您的代码执行时间产生巨大影响：

使用Option Explicit并将变量声明为最合适的日期类型 - 仅在需要时使用Variant。
将数据存储为数字（不是字符串），并使用单元格格式显示
不要循环（大）范围。将范围数据复制到变量数组，然后循环该数组。将结果复制回最后的工作表。在SO和其他地方有很多这方面的例子。

要显示数字作为Deg Minutes Seconds使用数字格式[h]°mm'ss\"这会利用时间格式，因此您需要将数字值创建为Deg/24 + Min/1440 + Sec/86400例如293°44'23"的值为{{} 1}}

Answer 2

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

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

在我的系统上，运行代码时 25.16秒 。通过对代码的上述更改，现在只需 3.16秒 即可执行相同的任务。

请注意，我还声明了所有变量，并使用工作表变量作为每个工作表的参考。虽然后者不会提高速度，但它只会提高代码的可读性。

优化代码以最小化宏的运行时

2 个答案: