Макрос VBA работает целую вечность, на других компьютерах работает хорошо

Question

Не могли бы вы помочь мне решить проблему с макросом, который обрабатывается слишком медленно? Я попытался изменить диапазон всего на 3 строки, и он был обработан за 1 минуту, в то время как на других компьютерах он длился всего 20 секунд для более чем 300 строк. Это вызвано обновлением Excel и динамическими массивами c? Если да, знаете ли вы, как это исправить?

Sub import_new_forecast()
Dim lrow, lcol, i, j, k As Long
Dim USED_WB As Workbook
Dim fcst_file As Variant
Dim data_arr(), ldata_arr(), colmap_arr(), fhead_arr(), head_arr()
Dim ans As Variant

fcst_file = Application.GetOpenFilename(Filefilter:="XLS Files, *.xls", Title:="Provide RSM path", MultiSelect:=False)
Set USED_WB = Application.Workbooks.Open(fcst_file)
With USED_WB.ActiveSheet
    lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
    Do Until CLng(.Cells(lrow, 2).Value) > 1 'Find last not empty row in RSM file
        lrow = lrow - 1
    Loop

    lcol = .Cells(1, .Columns.Count).End(xlToLeft).Column

    head_arr = Range(.Cells(1, 1), .Cells(1, lcol)).Value
    data_arr = Range(.Cells(2, 1), .Cells(lrow, lcol)).Value
End With

With ThisWorkbook.Sheets("Col_Map")
    lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
    colmap_arr() = Range(.Cells(2, 1), .Cells(lrow, 4))
End With

USED_WB.Close savechanges:=False

With ThisWorkbook.Sheets("Forecast")
lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
lcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    If lrow > 3 Then
        ans = MsgBox("Do you want to replace LForecast with current forecast?", vbYesNo)
        If ans = vbYes Then
            ThisWorkbook.Sheets("L_Forecast").Cells.Clear
            ThisWorkbook.Sheets("Forecast").Cells.Copy
            With ThisWorkbook.Sheets("L_Forecast").Cells(1, 1)
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
            End With
        End If
    End If

    If lrow <= 4 Then lrow = 4
    Range(.Cells(4, 1), .Cells(lrow, 1)).EntireRow.Delete
    fhead_arr = Range(.Cells(2, 1), .Cells(2, lcol)).Value
End With

With ThisWorkbook.Sheets("L_Forecast")
    lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
    lcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    ldata_arr = Range(.Cells(2, 1), .Cells(lrow, lcol)).Value
End With


ReDim final_arr(UBound(data_arr), UBound(fhead_arr, 2))
For i = 1 To UBound(final_arr)
    For j = 1 To UBound(final_arr, 2)
        If Not IsEmpty(colmap_arr(j, 3)) Then
            If IsNumeric(colmap_arr(j, 3)) Then
                If IsNumeric(data_arr(i, colmap_arr(j, 3))) Then
                    final_arr(i, j) = CDbl(data_arr(i, colmap_arr(j, 3)))
                Else
                    final_arr(i, j) = data_arr(i, colmap_arr(j, 3))
                End If
            ElseIf colmap_arr(j, 3) = "x" Then
                For k = 1 To UBound(ldata_arr)
                    If ldata_arr(k, 4) = final_arr(i, 4) Then
                        final_arr(i, j) = ldata_arr(k, j)
                    End If
                Next k
            ElseIf colmap_arr(j, 3) = "f" Then
                final_arr(i, j) = Replace(colmap_arr(j, 4), ";", ",")
            End If
        End If
    Next j
Next i

With ThisWorkbook.Sheets("Forecast")
    With .Cells(4, 1).Resize(UBound(final_arr), UBound(final_arr, 2))
        .Value = final_arr
        .Borders.LineStyle = xlContinuous
    End With
End With

End Sub
End With

Answer 1

Я исправил проблемную часть вашего кода. Пожалуйста, обратите внимание.

Sub import_new_forecast()
    'Dim lrow, lcol, i, j, k As Long '~~> vba requires you to format each variable on the same line
    Dim lrow As Long, lcol As Long, i As Long, j As Long, k As Long
    Dim USED_WB As Workbook
    Dim fcst_file As Variant
    Dim data_arr(), ldata_arr(), colmap_arr(), fhead_arr(), head_arr()
    Dim ans As Variant
    Dim Target As Range

    fcst_file = Application.GetOpenFilename(Filefilter:="XLS Files, *.xls", Title:="Provide RSM path", MultiSelect:=False)

    Set USED_WB = Application.Workbooks.Open(fcst_file)

    With USED_WB.ActiveSheet
        lrow = .Cells(.Rows.Count, 1).End(xlUp).Row

' ~~> The line below doesn't make sense.

'        Do Until CLng(.Cells(lrow, 2).Value) > 1 'Find last not empty row in RSM file
'            lrow = lrow - 1
'        Loop

        lcol = .Cells(1, .Columns.Count).End(xlToLeft).Column

        head_arr = .Range(.Cells(1, 1), .Cells(1, lcol)).Value      '<~~ comma(.) added
        data_arr = .Range(.Cells(2, 1), .Cells(lrow, lcol)).Value   '<~~ comma(.) added
    End With

    With ThisWorkbook.Sheets("Col_Map")
        lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        colmap_arr() = .Range(.Cells(2, 1), .Cells(lrow, 4)) '<~~ comma(.) added .Range
    End With

    USED_WB.Close savechanges:=False

    With ThisWorkbook.Sheets("Forecast")
        lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
            If lrow > 3 Then
                ans = MsgBox("Do you want to replace LForecast with current forecast?", vbYesNo)
                If ans = vbYes Then
                    ThisWorkbook.Sheets("L_Forecast").Cells.Clear
                    ThisWorkbook.Sheets("Forecast").Cells.Copy
                    With ThisWorkbook.Sheets("L_Forecast").Cells(1, 1)
                        .PasteSpecial xlPasteValues
                        .PasteSpecial xlPasteFormats
                    End With
                End If
            End If

        If lrow <= 4 Then lrow = 4
        'Range(.Cells(4, 1), .Cells(lrow, 1)).EntireRow.Delete
        .Range(.Cells(4, 1), .Cells(lrow, 1)).EntireRow.Clear   '<~~ comma(.) added .Range
        fhead_arr = .Range(.Cells(2, 1), .Cells(2, lcol)).Value '<~~ comma(.) added .Range
    End With

    With ThisWorkbook.Sheets("L_Forecast")
        lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        ldata_arr = .Range(.Cells(2, 1), .Cells(lrow, lcol)).Value '<~~ comma(.) added .Range
    End With

    'ReDim final_arr( UBound(data_arr),  UBound(fhead_arr, 2))
    ReDim final_arr(1 To UBound(data_arr), 1 To UBound(fhead_arr, 2)) '<~~ dimesion index start at 1
    '~~~>  The way you define it is that the array starts at zero.

    For i = 1 To UBound(final_arr)
        For j = 1 To UBound(final_arr, 2)
            If Not IsEmpty(colmap_arr(j, 3)) Then
                If IsNumeric(colmap_arr(j, 3)) Then
                    If IsNumeric(data_arr(i, colmap_arr(j, 3))) Then
                        final_arr(i, j) = CDbl(data_arr(i, colmap_arr(j, 3)))
                    Else
                        final_arr(i, j) = data_arr(i, colmap_arr(j, 3))
                    End If
                ElseIf colmap_arr(j, 3) = "x" Then
                    For k = 1 To UBound(ldata_arr)
                        If ldata_arr(k, 4) = final_arr(i, 4) Then
                            final_arr(i, j) = ldata_arr(k, j)
                        End If
                    Next k
                ElseIf colmap_arr(j, 3) = "f" Then
                    final_arr(i, j) = Replace(colmap_arr(j, 4), ";", ",")
                End If
            End If
        Next j
    Next i

    With ThisWorkbook.Sheets("Forecast")
        With .Cells(4, 1).Resize(UBound(final_arr), UBound(final_arr, 2))
            .Value = final_arr
            .Borders.LineStyle = xlContinuous
        End With
    End With

End Sub