Оптимизация кода !!!

[Rom213]

Всем приветик:
Тако вопросик, возможно ли оптимизировать следующий код, а то у меня когда оно считает(в диапозоне 1000 строек), пока все проверит, то мой комп умирает на 5 мин где то.
А вот и сам код:

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

Private Sub Raschet_Click()
    N = 0
    For Y = 7 To 10000
        If Worksheets("лист1").Cells(Y, 4).Value = "" Then
            Y = 10000
        Else
            Dim Produkt As Double
            Ostatok = 0
            For x = 7 To 10000
                If Worksheets("лист2").Cells(x, 4).Value = "" Then
                    x = 10000
                Else
                    If Worksheets("лист2").Cells(x, 4).Value = Worksheets("лист1").Cells(Y, 4).Value Then
                        If Worksheets("лист2").Cells(x, 6).Value = Worksheets("лист1").Cells(Y, 6).Value Then
                            If Worksheets("лист2").Cells(x, 2).Value = Worksheets("лист1").Cells(Y, 2).Value Then
                                Ostatok = Ostatok + Worksheets("лист2").Cells(x, 5).Value
                            End If
                        End If
                    End If
                End If
            Next x
            For x = 7 To 10000
                If Worksheets("лист3").Cells(x, 4).Value = "" Then
                    x = 10000
                Else
                    If Worksheets("лист3").Cells(x, 4).Value = Worksheets("лист1").Cells(Y, 4).Value Then
                        If Worksheets("лист3").Cells(x, 6).Value = Worksheets("лист1").Cells(Y, 6).Value Then
                            If Worksheets("лист3").Cells(x, 2).Value = Worksheets("лист1").Cells(Y, 2).Value Then
                                Ostatok = Ostatok + Worksheets("лист3").Cells(x, 5).Value
                            End If
                        End If
                    End If
                End If
            Next x
            Worksheets("лист1").Cells(Y, 8).Value = Worksheets("лист1").Cells(Y, 5).Value - Ostatok
            Worksheets("лист1").Cells(Y, 9).Value = Worksheets("лист1").Cells(Y, 8).Value * Worksheets("лист1").Cells(Y, 6).Value
            Worksheets("лист1").Cells(Y, 7).Value = Worksheets("лист1").Cells(Y, 5).Value * Worksheets("лист1").Cells(Y, 6).Value
        End If
    Next Y
End Sub


[KL]

Попробуй так (должно быть намного быстрее), но у меня такое подозрение, что цикл For x = 7 To 10000 внутри цикла For Y = 7 To 10000 тоже не нужен. Если так, то код мог бы сократиться до ~ 1 сек. Но докапываться до смысла этого кода без файла просто нет времени.

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

Private Sub Raschet_Click()
    Dim Produkt As Double, ws2 As Worksheet, ws3 As Worksheet
    Set ws2 = Worksheets("Лист2")
    Set ws3 = Worksheets("Лист3")
    Application.ScreenUpdating = False
    With Worksheets("Лист1")
        For Y = 7 To 10000
            If .Cells(Y, 4) = "" Then
                Y = 10000
            Else
                Ostatok = 0
                For x = 7 To 10000
                    If ws2.Cells(x, 4) = "" Then
                        x = 10000
                    ElseIf ws2.Cells(x, 4) = .Cells(Y, 4) And ws2.Cells(x, 6) = .Cells(Y, 6) And ws2.Cells(x, 2) = .Cells(Y, 2) Then
                        Ostatok = Ostatok + ws2.Cells(x, 5)
                    End If
                    If ws3.Cells(x, 4) = "" Then
                        x = 10000
                    ElseIf ws3.Cells(x, 4) = .Cells(Y, 4) And ws3.Cells(x, 6) = .Cells(Y, 6) And ws3.Cells(x, 2) = .Cells(Y, 2) Then
                        Ostatok = Ostatok + ws3.Cells(x, 5)
                    End If
                Next x
                .Cells(Y, 8) = .Cells(Y, 5) - Ostatok
                .Cells(Y, 9) = .Cells(Y, 8) * .Cells(Y, 6)
                .Cells(Y, 7) = .Cells(Y, 5) * .Cells(Y, 6)
            End If
        Next Y
    End With
    Application.ScreenUpdating = True
End Sub

[Rom213]

суть данного кода в том что запрос ищет строчку по трем параметрам в каждом из 6-ти листов в котором хватает ячеек, не учитывая то что сам основной лист содержит около 1000 строк, что кто может предложить. Я так посмотрел вродебы тоже время что и было.

[Rom213]

может файлик кинуть ???

[Rom213]

+ почему то в данном коде приведенном уважаемым KL, не все листы считает кое что пропускает непонимаю почему только.

[GSerg]

Rom213, пользуйся кнопкой для добавления неожиданно пришедших через две минуты мыслей.

[Rom213]

вот собственно файлик

[KL]

Нут-ка вот это.

[Rom213]

извиняюсь что поздно отвечаю, классно как всегда. KL самый реальный человек который может помочь .
Но есть один вопросик: В строке есть Почки 1909 2900, он ищет по 2 критериям в последующих листах,и в строке есть с такими же параметрами Почки свин 1909 2900,и он их включает в строку суммирования. Я так предполагаю что нужно ввести строгое соответствие ????
или как с этого выкрутится.

[KL]

Попробуй так:

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

Private Sub Raschet_Click()
    Dim rng As Range, j As Long, i As Long, x As Double
    Application.ScreenUpdating = False
    With Sheets(1)
        Set rng = .Range(.[B7], .[B65536].End(xlUp)).Resize(,
    End With
   
    For i = 1 To rng.Rows.Count
        With Sheets(7)
            .Range("A2") = rng(i, 1)
            .Range("B2") = "'=" & rng(i, 3)
            .Range("C2") = rng(i, 5)
        End With
        For j = 2 To 6
            x = x + Evaluate("DSUM(" & Sheets(j).Range("B6:G1000").Address(, , , True) _
                & ",4," & Sheets(7).Range("A1:C2").Address(, , , True) & ")")
        Next j
        rng(i, 7) = rng(i, 4) - x
        x = 0
    Next i
    Application.ScreenUpdating = True
End Sub

[Rom213]

вроде бы подходит, THK