Как сохранить значения в памяти, а потом вставить за раз всё

Пользователь

Сообщений: 17 Регистрация: 12.04.2019

24.05.2022 13:21:39

Здравствуйте!

Есть программа. Сейчас она вычисляет результаты и как я понимаю сразу записывает значения в ячейку. При расчёте до 10-50 строк всё происходит быстро. При расчёте несколько тысяч строк этот процесс занимает длительное время.

Можно ли сначала результаты расчёта хранить где-то в памяти, а потом в конце вставить всё одним целым. Тогда это проблема ушла бы.

код программы

Код

Sub VSP_A2()

'
' Удалить Макрос
'

    Range("A5").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A1").Select

Dim source As Worksheet, calculation As Worksheet, result As Worksheet
Dim LR As Long, LRR As Long

Set source = ThisWorkbook.Sheets("Усилия")
Set calculation = ThisWorkbook.Sheets("Проверка")
Set result = ThisWorkbook.Sheets("Выносливость")

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With
LR = source.Columns("A").Find("END", Range("A1"), xlValues, xlWhole, xlByRows, xlPrevious).Row

For i = 3 To LR

calculation.Range("S49").Value = source.Range("A" & i)

LRR = result.Cells(Rows.Count, 1).End(xlUp).Row + 1

result.Range("A" & LRR).Value = calculation.Range("S49").Value
result.Range("B" & LRR).Value = calculation.Range("AK50").Value
result.Range("C" & LRR).Value = calculation.Range("AN65").Value
result.Range("D" & LRR).Value = calculation.Range("AN68").Value
result.Range("E" & LRR).Value = calculation.Range("AN71").Value
result.Range("F" & LRR).Value = calculation.Range("AN74").Value

Next

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With

End Sub

Прикрепленные файлы

тест.xlsm (89.17 КБ)

Ігор Гончаренко

Пользователь

Сообщений: 14576 Регистрация: 01.01.1970

24.05.2022 13:33:05

Код

dim rez()
redim res(1 to Lr-2, 1 to 6): r = 1
For i = 3 To LR
  calculation.Range("S49").Value = source.Range("A" & i)
  res(r,1) = calculation.Range("S49").Value
  res(r,2) = calculation.Range("AK50").Value
  res(r,3)= calculation.Range("AN65").Value
  res(r,4) = calculation.Range("AN68").Value
  res(r,5) = calculation.Range("AN71").Value
  res(r,6) = calculation.Range("AN74").Value
  r = r + 1 
Next
result.rcells(result.Cells(Rows.Count, 1).End(xlUp).Row+1,1)resize(ubound(res),6) = res

Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!

Ronik

Пользователь

Сообщений: 17 Регистрация: 12.04.2019

24.05.2022 13:48:55

Спасибо за ответ.
Подскажите пожалуйста, что я неправильно делаю?
После "Next" у меня строчка красная и не работает

Код

Sub VSP_A2()

'
' Удалить Макрос
'

    Range("A5").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A1").Select

Dim source As Worksheet, calculation As Worksheet, result As Worksheet
Dim LR As Long, LRR As Long
Dim rez()

Set source = ThisWorkbook.Sheets("Усилия")
Set calculation = ThisWorkbook.Sheets("Проверка")
Set result = ThisWorkbook.Sheets("Выносливость")

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With
LR = source.Columns("A").Find("END", Range("A1"), xlValues, xlWhole, xlByRows, xlPrevious).Row

ReDim res(1 To LR - 2, 1 To 6): r = 1
For i = 3 To LR
  calculation.Range("S49").Value = source.Range("A" & i)
  res(r, 1) = calculation.Range("S49").Value
  res(r, 2) = calculation.Range("AK50").Value
  res(r, 3) = calculation.Range("AN65").Value
  res(r, 4) = calculation.Range("AN68").Value
  res(r, 5) = calculation.Range("AN71").Value
  res(r, 6) = calculation.Range("AN74").Value
  r = r + 1
Next
result.rcells(result.Cells(Rows.Count, 1).End(xlUp).Row+1,1)resize(ubound(res),6) = res

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With

End Sub

Прикрепленные файлы

Скриншот 24-05-2022 140242.jpg (130.36 КБ)

Изменено: Ronik - 24.05.2022 14:03:15

Alice Sadman

Пользователь

Сообщений: 89 Регистрация: 06.04.2021

24.05.2022 13:52:04

может надо так?

Код
result.cells(result.Cells(Rows.Count, 1).End(xlUp).Row+1,1).resize(ubound(res),6) = res

Изменено: Alice Sadman - 24.05.2022 13:52:40

МатросНаЗебре

Пользователь

Сообщений: 6468 Регистрация: 05.02.2014

24.05.2022 14:05:19

Ещё вариант.

Код

Sub VSP_A2()
 
'
' Удалить Макрос
'
 
    Range("A5").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A1").Select
 
    Dim source As Worksheet, calculation As Worksheet, result As Worksheet
    Dim LR As Long, LRR As Long
     
    Set source = ThisWorkbook.Sheets("Усилия")
    Set calculation = ThisWorkbook.Sheets("Проверка")
    Set result = ThisWorkbook.Sheets("Выносливость")
     
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    LR = source.Columns("A").Find("END", Range("A1"), xlValues, xlWhole, xlByRows, xlPrevious).Row
         
    Dim arr_result As Variant
    ReDim arr_result(1 To LR - 2, 1 To 6)
    
    Dim arr_calculation As Variant
    
    Dim i As Long
    For i = 3 To LR
     
        calculation.Range("S49").Value = source.Range("A" & i)
        arr_calculation = calculation.Cells(1, 1).Resize(74, 40)
         
        arr_result(i - 2, 1) = arr_calculation(49, 19)
        arr_result(i - 2, 2) = arr_calculation(50, 37)
        arr_result(i - 2, 3) = arr_calculation(65, 40)
        arr_result(i - 2, 4) = arr_calculation(68, 40)
        arr_result(i - 2, 5) = arr_calculation(71, 40)
        arr_result(i - 2, 6) = arr_calculation(74, 40)
     
    Next
    
    result.Cells(Rows.Count, 1).End(xlUp).Cells(2, 1).Resize(UBound(arr_result, 1), UBound(arr_result, 2)) = arr_result
     
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
 
End Sub

Ronik Пользователь Сообщений: 17 Регистрация: 12.04.2019	#6 24.05.2022 15:24:57 Спасибо всем большое. Но почему то при 1500 строк excel сильно задумывается.

kohet

Пользователь

Сообщений: 27 Регистрация: 13.10.2019

24.05.2022 17:58:33

Цитата
написал: Спасибо всем большое. Но почему то при 1500 строк excel сильно задумывается.

Потому что Resize зациклено и каждый раз переопределяет массив.
Проще сразу рассчитать размер массива и просто записывать туда значения по условию.

МатросНаЗебре

Пользователь

Сообщений: 6468 Регистрация: 05.02.2014

25.05.2022 09:03:53

Цитата
просто записывать туда значения

Код
Dim r_calculation As Long set r_calculation = calculation.Cells(1, 1).Resize(74, 40) For i = 3 To LR calculation.Range("S49").Value = source.Range("A" & i) arr_calculation = r_calculation

Ronik

Пользователь

Сообщений: 17 Регистрация: 12.04.2019

25.05.2022 09:29:02

МатросНаЗебре,
Выдал ошибку. Не могу понять что с переменными не так

Код

'
' Удалить Макрос
'

    Range("A5").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A1").Select

    Dim source As Worksheet, calculation As Worksheet, result As Worksheet
    Dim LR As Long, LRR As Long
    Dim r_calculation As Long
      
    Set source = ThisWorkbook.Sheets("Усилия")
    Set calculation = ThisWorkbook.Sheets("Проверка")
    Set result = ThisWorkbook.Sheets("Выносливость")
    Set r_calculation = calculation.Cells(1, 1).Resize(74, 40)
      
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    LR = source.Columns("A").Find("END", Range("A1"), xlValues, xlWhole, xlByRows, xlPrevious).Row
          
    Dim arr_result As Variant
    ReDim arr_result(1 To LR - 2, 1 To 6)
     
    Dim arr_calculation As Variant
     
    Dim i As Long
    For i = 3 To LR
      
        calculation.Range("S49").Value = source.Range("A" & i)
        arr_calculation = r_calculation
          
        arr_result(i - 2, 1) = arr_calculation(49, 19)
        arr_result(i - 2, 2) = arr_calculation(50, 37)
        arr_result(i - 2, 3) = arr_calculation(65, 40)
        arr_result(i - 2, 4) = arr_calculation(68, 40)
        arr_result(i - 2, 5) = arr_calculation(71, 40)
        arr_result(i - 2, 6) = arr_calculation(74, 40)
      
    Next
     
    result.Cells(Rows.Count, 1).End(xlUp).Cells(2, 1).Resize(UBound(arr_result, 1), UBound(arr_result, 2)) = arr_result
      
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
  
End Sub

Прикрепленные файлы

Скриншот 25-05-2022 092855.jpg (132.48 КБ)

V Пользователь Сообщений: 5194 Регистрация: 22.12.2012	#10 25.05.2022 09:36:52 Dim r_calculation As Range