優化代碼以最小化宏的運行時間

Question

我一直在編寫一些宏來執行一些占星計算（計算符號，月宮，D9 & D60）。的原始數據是使用以下格式：

LNG上述圖像中的代表在度，分，秒格式表示經度。輸出必須是在以下格式：

我已掀起了下面的代碼來讀取從輸入片材和格式&的數據複製到輸出片材，然後用的經度做計算每個行星都要計算所需的場地。

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

有幾件事情你可以做。首先，聲明所有變量可節省內存，從而節省時間。話雖如此，代碼中真正耗時的因素是循環遍歷每個單元格。獲得相同結果的最快方法是將數據讀入數組，然後將數組寫入輸出表。在下面的代碼中，我編輯了prepareOutput子版，它保留了你的初始代碼結構，但是不是循環讀寫每個單元，而是將數據讀入數組，然後將該數組寫入所需的輸出區域。

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秒執行相同的任務。

請注意，我還聲明的所有變量和使用工作表，變量指向同每個工作表。雖然後者不會提高速度，但它只會提高代碼的可讀性。

Answer 2

這裏有一些提示，這將產生巨大的變化，以您的代碼執行時間：

1. 使用Option Explicit和聲明變量作爲最合適的日期類型 - 只有當你需要使用Variant至。
2. 將您的數據存儲一個數字（不是字符串），並使用單元格格式以便隨意顯示
3. 不要循環（大）範圍。將範圍數據複製到變體數組，並循環數組。將結果複製回最後的表格。 SO和其他地方有很多這方面的例子。

要顯示一個數字作爲度分秒使用數字格式[h]°mm'ss\"這充分利用了時間格式，所以你需要創建的數值爲Deg/24 + Min/1440 + Sec/86400如293°44'23"具有價值12.2391550925926