Оптимизация кода для минимизации времени выполнения макроса

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 таким образом, что он сохраняет вашу исходную структуру кода, но вместо того, чтобы перебирать и записывать в каждую ячейку, теперь он считывает данные в массив и затем записывает этот массив в желаемая область вывода.

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 и в других местах.

Чтобы отобразить номер как Deg Минуты Секунды использовать формат чисел [h]°mm'ss\" Это использует формат времени, так что вам нужно создать числовое значение, как Deg/24 + Min/1440 + Sec/86400 Например 293°44'23" имеет значение 12.2391550925926