с каждой итерацией цикл работает все реже и реже

[jojo]

Уважаемые гуру !
У вас не было такой проблемы

Есть 2 файла
Есть цикл с 2000 записями Excel
внутри него еще цикл с 2000 записями
сравнение идет по 3 столбцам ...обоих файлов
такой груз работает 15 мин

причем с каждой итерацией цикл работает все реже и реже ) ->
как бороться за память ...
чтоб все быстрей крутилось

Спасибо

[RayShade]

По моему надо изобрести новый способ решения задачи. Вложенный цикл это как то в лоб слишком. Естественно, что он будет пожирать ресурсы. 2000 в кубе это же восемь миллиардов итераций...

Что за задача вообще?

[jojo]

Sub Kolbasa()


' Погнали по 1 пакету
i1 = 7
While Not IsEmpty(ObJ_EP1.Cells(i1, 1).Value)
i1 = i1 + 1
DoEvents
Wend

str_all = i1

' Погнали по 1 пакету
i1 = 7
While Not IsEmpty(ObJ_EP1.Cells(i1, 1).Value)

ac_EP1 = CStr(ObJ_EP1.Cells(i1, 2).Value) & CStr(ObJ_EP1.Cells(i1, 3).Value) & CStr(ObJ_EP1.Cells(i1, 4).Value)

If IsNumeric(ObJ_EP1.Cells(i1, 6).Value) And Not ObJ_EP1.Cells(i1, 6).Locked Then
SumSaldoDt_EP1 = CDbl(ObJ_EP1.Cells(i1, 6).Value)
Else
SumSaldoDt_EP1 = 0
End If

If IsNumeric(ObJ_EP1.Cells(i1, 7).Value) And Not ObJ_EP1.Cells(i1, 7).Locked Then
SumSaldoKt_EP1 = ObJ_EP1.Cells(i1, 7).Value
Else
SumSaldoKt_EP1 = 0
End If


Call Find_ac(ac_EP1, flag_yes, SumSaldoDt_EP1, SumSaldoKt_EP1)

i1 = i1 + 1
DoEvents
Wend ' While Not IsEmpty(ObJ_EP1.Cells(i1, 1).Value)

Windows(NameEP1).Close SaveChanges:=False
Windows(NameEP2).Close SaveChanges:=False
Application.StatusBar = ""



End Sub
Public Sub Find_ac(ac As String, flag_yes As Integer, SumSaldoDt_EP1 As Double, SumSaldoKt_EP1 As Double)

Application.ScreenUpdating = False
flag_yes = 0

'ac = ac_EP1
Application.StatusBar = "Сравниваю счет №: " & ac_EP1 & " Пакет- " & NameEP2_Full & "_" & Name_Fil & ".xls"
i2 = 7
While Not IsEmpty(ObJ_EP2_1.Cells(i2, 1).Value)

ac_EP2 = CStr(ObJ_EP1.Cells(i2, 2).Value) & CStr(ObJ_EP1.Cells(i2, 3).Value) & CStr(ObJ_EP1.Cells(i2, 4).Value)
' Сравниваем номера счетов
If ac_EP2 = ac_EP1 Then
flag_yes = 1

' Сравним суммы входящего сальдо
If IsNumeric(ObJ_EP2_1.Cells(i2, 6).Value) And Not ObJ_EP2_1.Cells(i2, 6).Locked Then
SumSaldoDt_EP2 = ObJ_EP2_1.Cells(i2, 6).Value
Else
SumSaldoDt_EP2 = 0
End If

If IsNumeric(ObJ_EP2_1.Cells(i2, 7).Value) And Not ObJ_EP2_1.Cells(i2, 7).Locked Then
SumSaldoKt_EP2 = ObJ_EP2_1.Cells(i2, 7).Value
Else
SumSaldoKt_EP2 = 0
End If

' Проверим дебетовое сальдо
If Not (SumSaldoDt_EP1 = SumSaldoDt_EP2) Then
' Не совпадают !!! Пишем в протокол ошибок

i_pr = 2
While Not IsEmpty(ObJ_prot.Cells(i_pr, 1).Value)
i_pr = i_pr + 1
DoEvents
Wend

ObJ_prot.Cells(i_pr, 1).Value = Name_Fil
ObJ_prot.Cells(i_pr, 2).Value = ac_EP1
ObJ_prot.Cells(i_pr, 3).Value = SumSaldoDt_EP1
ObJ_prot.Cells(i_pr, 4).Value = "-"

ObJ_prot.Cells(i_pr, 5).Value = ac_EP2
ObJ_prot.Cells(i_pr, 6).Value = SumSaldoDt_EP2
ObJ_prot.Cells(i_pr, 7).Value = "-"
ObJ_prot.Cells(i_pr, .Value = "Дебетовое сальдо не совпадает !"


End If 'If SumSaldoDt_EP1 = SumSaldoDt_EP2 Then

' Проверим кредитовое сальдо
If Not (SumSaldoKt_EP1 = SumSaldoKt_EP2) Then
' Не совпадают !!! Пишем в протокол ошибок
flag_error = 1
i_pr = 2
While Not IsEmpty(ObJ_prot.Cells(i_pr, 1).Value)
i_pr = i_pr + 1
DoEvents
Wend

ObJ_prot.Cells(i_pr, 1).Value = Name_Fil
ObJ_prot.Cells(i_pr, 2).Value = ac_EP1
ObJ_prot.Cells(i_pr, 3).Value = "-"
ObJ_prot.Cells(i_pr, 4).Value = SumSaldoKt_EP1

ObJ_prot.Cells(i_pr, 5).Value = ac_EP2
ObJ_prot.Cells(i_pr, 6).Value = "-"
ObJ_prot.Cells(i_pr, 7).Value = SumSaldoKt_EP2
ObJ_prot.Cells(i_pr, .Value = "Кредитовое сальдо не совпадает !"

End If 'If SumSaldoKt_EP1 = SumSaldoKt_EP2 Then

Exit Sub

End If 'If CStr(ObJ_EP2_1.Cells(i2, 1).Value) = ac Then

i2 = i2 + 1
DoEvents
Wend


Application.ScreenUpdating = True

End Sub

[jojo]

Сравниваются два бухлтерских баланса на начало года
по начальных сальдо

[jojo]

Ессно что это только процедура кот вызывается их другой
работает эта хрень около 15 мин ...на один баланс
а их около 20 ))
работало все это 6 часов где-то

[Sebas]

для начала, я б DoEvents убрал

[Igor_123]

Если можно покажи примерные значения данных которые анализируются.
У меня в похожей задаче однажды производительность упала с часа-полутора практически до полной остановки. Виноватой оказалась текстовая запись в столбце чисел. (строк в файле было около 120 тыс.)

[alibek]

Виноватой оказалась текстовая запись в столбце чисел. (строк в файле было около 120 тыс.)

Обманываешь... В Excel 97/2000/XP/2003 может быть максимум 65536 строк.

[Igor_123]

Сам не верил пока не увидел. Ничего необычного так и не выяснил.
WinXP Prof
OfficeXP Prof
Pentium ~ 3 ГГц
ОЗУ ~ 1,256 Gb

[DTech]

Операции с ячейками в Excel иногда жутко тормозные. Критичные по производительности объемы можно загнать в массивы. У меня в одной такой задаче производительность после этого возросла на порядок.

[corgi]

если это баланс то в нем около 700 параметров (это в годовом, а так еще меньше) так что надо просто набить их список и потом по списку пройтись, ну или как нибудь отметить то что надо сравнивать а не творить три вложенных цикла...

[Igor_123]

Можно не исполнять

Код: Выделить всё

While Not IsEmpty(ObJ_EP1.Cells(i1, 1).Value)
    i1 = i1 + 1
    DoEvents
Wend

.
Я делаю так

Код: Выделить всё

CurrentPositionY = 2
pusto = 0

Do

' Код выполняющий работу

CurrentPositionY = CurrentPositionY + 1
    If ChekEndBasa(CurrentPositionY) Then
        pusto = pusto + 1
    Else
        pusto = 0
    End If
Loop Until pusto > 5
.
.
.

Private Function ChekEndBasa(CurRow As Long) As Boolean
Dim i As Long, count As Long
count = 1
For i = 1 To 22
    If Cells(CurRow, i).Value = "" Then
       count = count + 1
    End If
Next i
ChekEndBasa = IIf((count = i), True, False)
End Function

для грубой проверки можно использовать

Код: Выделить всё

EndDataInSheet = Selection.End(xlDown).Row

или применять проверку через ~100 строк по пустой назад 50, по заполненной - вперед 25 и т.д.

потом

Код: Выделить всё

Public Sub Find_ac(ac As String, flag_yes As Integer, SumSaldoDt_EP1 As Double, SumSaldoKt_EP1 As Double)

Application.ScreenUpdating = False

можно перенести в

Код: Выделить всё

Sub Kolbasa()
Application.ScreenUpdating = False

и включать апдейт вообще по окончании всей работы.

Еще один момент

Код: Выделить всё

i_pr = 2
            While Not IsEmpty(ObJ_prot.Cells(i_pr, 1).Value)
                i_pr = i_pr + 1
                DoEvents
            Wend

проще завести глобальную переменную для хранения текущей свободной строки для протокола, я в исходных файлах ещё и изменяю цвет ошибочных строк или мне выделяют столбец в который сбрасываю описание ошибки(по автофильтру легко найти)

и DoEvents я бы оставил но только в функции Find_ac

[Igor_123]

Да и ещё забыл у тебя работа идет с разными файлами, я в начале работы создаю книгу в которой собираю все необходимые листы, закрываю исходные и работаю с одним файлом