Сравнение макросов - Microsoft Office Excel

valerij · 04.06.2008, 11:21

Оригинал

Код:

Sub Sum()

    Dim myCollect As New Collection, i As Integer, x As Range, Summa As Double, El
    Dim a As Long, b As Long, c As Integer
    Application.ScreenUpdating = False
    a = 3: b = 36: c = 48: Summa = 0
    Do
        On Error Resume Next
        For i = Sheets(1).Cells(b, "I").End(xlUp).Row To a Step -1
            If Sheets(1).Cells(i, "I") <> "" And Sheets(1).Cells(i, "I") <> 0 Then myCollect _
                .Add Sheets(1).Cells(i, "I").Value, CStr(Sheets(1).Cells(i, "I").Value)
        Next
        On Error GoTo 0
    
        Sheets(1).Range(Sheets(1).Cells(Sheets(1).Cells(b, "I").End(xlUp).Row + 1, "I"), Sheets(1).Cells(b, "I")) _
            .ClearContents
        Sheets(1).Range(Sheets(1).Cells(Sheets(1).Cells(b, "I").End(xlUp).Row + 1, "I"), Sheets(1).Cells(b, "I")) _
            .Font.ColorIndex = 0
        d = b
        For Each El In myCollect
            Set x = Sheets("НАКЛ").Columns("IU").Find(what:=El, LookAt:=xlPart)
            If Not x Is Nothing Then
                Sheets(1).Cells(d - 1, "I") = x
                Sheets(1).Cells(d - 1, "I").Font.ColorIndex = 10
                Sheets(1).Cells(d, "I") = Sheets("НАКЛ").Cells(x.Row, "E")
                Summa = Summa + Sheets("НАКЛ").Cells(x.Row, "E")
                d = d - 2
            End If
        Next
        Sheets(1).Cells(b + 1, "I") = Summa
        Set myCollect = Nothing
        Summa = 0
        a = a + c: b = b + c
    Loop While Sheets(1).Cells(b, "C") <> ""

End Sub

Первое изменение
Здесь данные с клавы, вводятся в диапазон I31:I36
Скорость в обоих марасах одинакова(>)

Код:

Sub Sum()
L = ActiveSheet.Index
    Dim myCollect As New Collection, i As Integer, x As Range, Summa As Double, El
    Dim a As Long, b As Long, c As Integer
    Application.ScreenUpdating = False
    a = 19: b = 36: c = 48: Summa = 0
    Do
        On Error Resume Next
        For i = Sheets(L).Cells(a, "I").End(xlUp).Row To b 'Step -1
            If Sheets(L).Cells(i, "I") <> "" And Sheets(L).Cells(i, "I") <> 0 Then myCollect _
                .Add Sheets(L).Cells(i, "I").Value, CStr(Sheets(L).Cells(i, "I").Value)
        Next
        On Error GoTo 0
        Sheets(L).Range(Sheets(L).Cells(Sheets(L).Cells(b, "I").End(xlUp).Row + 1, "I"), Sheets(L).Cells(b, "I")) _
            .ClearContents
        Sheets(L).Range(Sheets(L).Cells(Sheets(L).Cells(b, "I").End(xlUp).Row + 1, "I"), Sheets(L).Cells(b, "I")) _
            .Font.ColorIndex = 0
        d = a - 1
        For Each El In myCollect
            Set x = Sheets("НАКЛ").Columns("IU").Find(what:=El, LookAt:=xlPart)
            If Not x Is Nothing Then
                Sheets(L).Cells(d + 1, "I") = x
                Sheets(L).Cells(d + 1, "I").Font.ColorIndex = 11
                Sheets(L).Cells(d + 2, "I") = Sheets("НАКЛ").Cells(x.Row, "E")
                Summa = Summa + Sheets("НАКЛ").Cells(x.Row, "E")
                d = d + 2
            End If
        Next
        Sheets(L).Cells(b + 1, "I") = Summa
        Set myCollect = Nothing
        Summa = 0
        a = a + c: b = b + c
    Loop While Sheets(L).Cells(b, "C") <> ""
End Sub

В следующем изменяю скорость, но ????

Код:

Sub Sum()
L = ActiveSheet.Index
    Dim myCollect As New Collection, i As Integer, x As Range, Summa As Double, El
    Dim a As Long, b As Long, c As Integer, k As Long
    a = 19: b = 36: c = 48: Summa = 0
    With Application
    .EnableEvents = False
    .ScreenUpdating = False
    For k = a To 1459 Step 48
    Range("I" & k & ":I" & k + 11).ClearContents
    With Range("I" & k) ' & ":I" & k + 5)
    .FormulaR1C1 = "=IF(COUNTIF(НАКЛ!R2C255:R1207C255,R[12]C)>0,R[12]C,0)" 'Задается диапазон поиска R2-R1207, лист НАКЛ(С2:С1207)
    'Do
        On Error Resume Next
        For i = Sheets(L).Cells(a, "I").End(xlUp).Row To b
            If Sheets(L).Cells(i, "I") <> "" And Sheets(L).Cells(i, "I") <> 0 Then myCollect _
                .Add Sheets(L).Cells(i, "I").Value, CStr(Sheets(L).Cells(i, "I").Value)
        Next
        On Error GoTo 0
        d = a - 1
        For Each El In myCollect
            Set x = Sheets("НАКЛ").Columns("IU").Find(what:=El, LookAt:=xlPart)
            If Not x Is Nothing Then
                Sheets(L).Cells(d + 1, "I") = x
                Sheets(L).Cells(d + 1, "I").Font.ColorIndex = 11 ': .NumberFormat = "General"
                Sheets(L).Cells(d + 2, "I") = Sheets("НАКЛ").Cells(x.Row, "E")
                Summa = Summa + Sheets("НАКЛ").Cells(x.Row, "E")
                d = d + 2
            End If
        Next
        Sheets(L).Cells(b + 1, "I") = Summa
        Set myCollect = Nothing
        Summa = 0
        a = a + c: b = b + c
    'Loop While Sheets(L).Cells(b, "C") <> ""
    End With
    Next
     .EnableEvents = True
    .ScreenUpdating = True
    End With
End Sub

valerij · 04.06.2008, 11:46

В этом варианте скорость мгновенная, но вывод совпадений, таков, сначала №, затем их суммы, чередование № и суммы не получилось.

Код:

Sub Sum()
L = ActiveSheet.Index
    Dim myCollect As New Collection, i As Integer, x As Range, Summa As Double, El
    Dim a As Long, b As Long, c As Integer, k As Long
    a = 3: b = 36: c = 48: Summa = 0: rez = 6
    With Application
    .EnableEvents = False
    .ScreenUpdating = False
    For k = 19 To 1459 Step 48
    Range("I" & k & ":I" & k + 11).ClearContents
    With Range("I" & k & ":I" & k + 5)
    .FormulaR1C1 = "=IF(COUNTIF(НАКЛ!R2C255:R1207C255,R[12]C)>0,R[12]C,0)" 'Задается диапазон поиска R2-R1207, лист НАКЛ(С2:С1207)
       'Do
        On Error Resume Next
        For i = a To b
            If Sheets(L).Cells(i, "I") <> "" And Sheets(L).Cells(i, "I") <> 0 _
                And Sheets(L).Cells(i, "I").HasFormula Then myCollect _
                .Add Sheets(L).Cells(i, "I").Value, CStr(Sheets(L).Cells(i, "I").Value)
        Next
        On Error GoTo 0
           For Each El In myCollect
            Set x = Sheets("НАКЛ").Columns("IU").Find(what:=El, LookAt:=xlPart)
            If Not x Is Nothing Then Summa = Summa + Sheets("НАКЛ").Cells(x.Row, "E"): v = v + 1
            If k + rez < k + rez + v Then
        Sheets(L).Cells(k + rez, "I") = Sheets("НАКЛ").Cells(x.Row, "E")
        rez = rez + 1
        End If
        Next
        Sheets(L).Cells(b + 1, "I") = Summa
        Set myCollect = Nothing
        Summa = 0
        v = 0
        rez = 6
        a = a + c: b = b + c
        Range("I" & k + 19).Select
        ActiveCell.FormulaR1C1 = "=RC[-3]-R[-1]C"
    'Loop While Sheets(1).Cells(b, "C") <> ""
    End With
    Next
    .EnableEvents = True
    .ScreenUpdating = True
    End With
End Sub

SAS888 · 04.06.2008, 13:06

В оригинале (пост № 1) Работа построена следующим образом:
1) Данные вводятся в диапазон с ячейки "I3" и далее вниз по столбцу "I", но не более 11 значений, т.к. при 11 значениях, если найдутся все, то необходимо будет вписать еще 11 найденных значений и 11 сумм, т.е. 3*11 = 33. Как раз весь свободный диапазон "I3:I36". При превышении, макрос выдаст ошибку.
2) Итак, вручную данные вводятся, начиная сверху. Никаких формул в этот диапазон вставлять не нужно. Макрос ищет в листе "НАКЛ" каждое введенное значение, и при обнаружении - записывает в диапазон "I3:I36" найденное значение и соответствующую ему сумму, заполняя диапазон снизу.
3) Далее, вниз по столбцу "I" все то же с шагом 48, пока не кончится таблица (оператор Do...Loop While).
Вот и все. Нужно ли Вам это делать на всех листах сразу, или по отдельности - дело Ваше.
P.S. Я попытался пояснить то, что сделал. Что не устраивает? Может что не так, или еще что-нибудь нужно?

valerij · 04.06.2008, 13:15

Цитата:

Сообщение от SAS888

Что не устраивает? Может что не так, или еще что-нибудь нужно?

SAS888
Данные должны вводится только в диапазоне I31:I36(во всех листах), их будет не более шести, этот диапазон выбран не случайно.

Вот на скрине как надо, что бы было.
Что то скрин обрезает размеры, доп. в rar-e

SAS888 · 04.06.2008, 13:27

Вводиться??? Вручную???
Уточните. Ранее ручной ввод был в диапазоне "I3:I8".

valerij · 04.06.2008, 13:30

Цитата:

Сообщение от SAS888

Вводиться??? Вручную???
Уточните. Ранее ручной ввод был в диапазоне "I3:I8".

Да, вручную, но в "I31:I36", диапазон, а не в "I3:I8"(изменил, не удобно очень)
Посмотрите скрин!

SAS888 · 04.06.2008, 13:49

Тогда давайте сделаем вывод найденных номеров и соответствующих им сумм начиная сверху. Годится?

valerij · 04.06.2008, 13:59

Цитата:

Сообщение от SAS888

Тогда давайте сделаем вывод найденных номеров и соответствующих им сумм начиная сверху. Годится?

Да, сверху, но в диапазоне, I19:I30, SAS888, посмотрите скрин, Вам все станет ясно!

И еще о скорости, почему такая разница, между макросом 1 и 3(4)

SAS888 · 04.06.2008, 14:16

Разная скорость потому, что в "медленных" макросах происходит запись в ячейки формул, причем с большим диапазоном.
Теперь по делу:
Т.е. Вы хотите именно так, как у Вас в скрине? На тех же самых местах? Ограничение - 6 записей?

valerij · 04.06.2008, 14:19

Цитата:

Сообщение от SAS888

Т.е. Вы хотите именно так, как у Вас в скрине? На тех же самых местах? Ограничение - 6 записей?

Все верно, именно так как на скрине и цвет, и формат как на скрине(уж мед, так и ложку)

04.06.2008, 13:06	#3
SAS888 Старожил Регистрация: 05.12.2007 Сообщений: 4,180	В оригинале (пост № 1) Работа построена следующим образом: 1) Данные вводятся в диапазон с ячейки "I3" и далее вниз по столбцу "I", но не более 11 значений, т.к. при 11 значениях, если найдутся все, то необходимо будет вписать еще 11 найденных значений и 11 сумм, т.е. 311 = 33. Как раз весь свободный диапазон "I3:I36". При превышении, макрос выдаст ошибку. 2) Итак, вручную данные вводятся, начиная сверху. Никаких формул в этот диапазон вставлять не нужно. Макрос ищет в листе "НАКЛ" каждое введенное значение, и при обнаружении - записывает в диапазон "I3:I36" найденное значение и соответствующую ему сумму, заполняя диапазон снизу*. 3) Далее, вниз по столбцу "I" все то же с шагом 48, пока не кончится таблица (оператор Do...Loop While). Вот и все. Нужно ли Вам это делать на всех листах сразу, или по отдельности - дело Ваше. P.S. Я попытался пояснить то, что сделал. Что не устраивает? Может что не так, или еще что-нибудь нужно? Чем шире угол зрения, тем он тупее.

04.06.2008, 13:27	#5
SAS888 Старожил Регистрация: 05.12.2007 Сообщений: 4,180	Вводиться??? Вручную??? Уточните. Ранее ручной ввод был в диапазоне "I3:I8". Чем шире угол зрения, тем он тупее.

04.06.2008, 13:49	#7
SAS888 Старожил Регистрация: 05.12.2007 Сообщений: 4,180	Тогда давайте сделаем вывод найденных номеров и соответствующих им сумм начиная сверху. Годится? Чем шире угол зрения, тем он тупее.

04.06.2008, 14:16	#9
SAS888 Старожил Регистрация: 05.12.2007 Сообщений: 4,180	Разная скорость потому, что в "медленных" макросах происходит запись в ячейки формул, причем с большим диапазоном. Теперь по делу: Т.е. Вы хотите именно так, как у Вас в скрине? На тех же самых местах? Ограничение - 6 записей? Чем шире угол зрения, тем он тупее.

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Как использовать возможности Макросов MASM'а	Stilet	Assembler - Ассемблер (FASM, MASM, WASM, NASM, GoASM, Gas, RosAsm, HLA) и не рекомендуем TASM	5	27.05.2008 15:47
Скорость макросов в Excel 2007	June	Microsoft Office Excel	3	14.02.2008 12:06
Как ускорить выполнение макросов	tat-besidovska	Microsoft Office Excel	1	22.01.2008 12:12