Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Ускорить работу макроса нахождения кол-ва по трем условиям - Мир MS Excel

Старая форма входа
  • Страница 1 из 2
  • 1
  • 2
  • »
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Ускорить работу макроса нахождения кол-ва по трем условиям (Макросы/Sub)
Ускорить работу макроса нахождения кол-ва по трем условиям
китин Дата: Четверг, 28.07.2016, 11:51 | Сообщение № 1
Группа: Модераторы
Ранг: Экселист
Сообщений: 7013
Репутация: 1073 ±
Замечаний: 0% ±

Excel 2007;2010;2016
Всем доброго времени !!!!! Продолжаются попытки хоть как то уменьшить размер и увеличить скорость работы моих огромных файлов.В свете этого была предпринята попытка написать макрос вставки формул в ячейки, копирования и вставки значений с последующим уничтожением нулей(спасибо Ярославу за макрос).Получился вот такой вот монстр ъ


вполне рабочий, но на моих объемах очень медленный. Можно его как то ускорить?
К сообщению приложен файл: 4430277.xlsm (71.3 Kb)


Не судите очень строго:я пытаюсь научиться
ЯД 41001877306852


Сообщение отредактировал китин - Четверг, 28.07.2016, 11:53
 
Ответить
СообщениеВсем доброго времени !!!!! Продолжаются попытки хоть как то уменьшить размер и увеличить скорость работы моих огромных файлов.В свете этого была предпринята попытка написать макрос вставки формул в ячейки, копирования и вставки значений с последующим уничтожением нулей(спасибо Ярославу за макрос).Получился вот такой вот монстр ъ


вполне рабочий, но на моих объемах очень медленный. Можно его как то ускорить?

Автор - китин
Дата добавления - 28.07.2016 в 11:51
SGerman Дата: Четверг, 28.07.2016, 12:26 | Сообщение № 2
Группа: Пользователи
Ранг: Участник
Сообщений: 97
Репутация: 4 ±
Замечаний: 20% ±

Excel 2003
Попробуйте так :
1.
[vba]
Код
Application.ScreenUpdating = False
  <Код>
Application.ScreenUpdating = True
[/vba]

2. Убрать ненужные Select. Например вместо

[vba]
Код
    Range("B1").Select
    Selection.AutoFill Destination:=Range(Cells(1, 2), Cells(1, lLastCol)), Type:=xlFillDefault
[/vba]
Просто
[vba]
Код
    Range("B1").AutoFill Destination:=Range(Cells(1, 2), Cells(1, lLastCol)), Type:=xlFillDefault
[/vba]


Мудрость приходит со старостью. Но иногда старость приходит одна :)
 
Ответить
СообщениеПопробуйте так :
1.
[vba]
Код
Application.ScreenUpdating = False
  <Код>
Application.ScreenUpdating = True
[/vba]

2. Убрать ненужные Select. Например вместо

[vba]
Код
    Range("B1").Select
    Selection.AutoFill Destination:=Range(Cells(1, 2), Cells(1, lLastCol)), Type:=xlFillDefault
[/vba]
Просто
[vba]
Код
    Range("B1").AutoFill Destination:=Range(Cells(1, 2), Cells(1, lLastCol)), Type:=xlFillDefault
[/vba]

Автор - SGerman
Дата добавления - 28.07.2016 в 12:26
SGerman Дата: Четверг, 28.07.2016, 12:33 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 97
Репутация: 4 ±
Замечаний: 20% ±

Excel 2003
Боюсь надоесть всем своими "советами", но !
У Вас много данных и много вычислений. Кардинально (на порядки) скорость можно увеличить, поместив все данные в БД Access и все вычисления проводить там запросами. Еще лучше SQL Server+StorageProc
Все вычисления и отображения данных (если заполнения ячеек делать массивами) будут выполняться мгновенно !


Мудрость приходит со старостью. Но иногда старость приходит одна :)
 
Ответить
СообщениеБоюсь надоесть всем своими "советами", но !
У Вас много данных и много вычислений. Кардинально (на порядки) скорость можно увеличить, поместив все данные в БД Access и все вычисления проводить там запросами. Еще лучше SQL Server+StorageProc
Все вычисления и отображения данных (если заполнения ячеек делать массивами) будут выполняться мгновенно !

Автор - SGerman
Дата добавления - 28.07.2016 в 12:33
Саня Дата: Четверг, 28.07.2016, 12:53 | Сообщение № 4
Группа: Друзья
Ранг: Ветеран
Сообщений: 1068
Репутация: 560 ±
Замечаний: 0% ±

XL 2016
этот кусок:
[vba]
Код
    Range(Cells(30, 2), Cells(30, lLastCol)).Select
    Selection.Copy  ' копируем
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False 'вставляем значения
[/vba]

заменяем на:
[vba]
Код
with Range(Cells(30, 2), Cells(30, lLastCol))
   .value = .value
end with
[/vba]
 
Ответить
Сообщениеэтот кусок:
[vba]
Код
    Range(Cells(30, 2), Cells(30, lLastCol)).Select
    Selection.Copy  ' копируем
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False 'вставляем значения
[/vba]

заменяем на:
[vba]
Код
with Range(Cells(30, 2), Cells(30, lLastCol))
   .value = .value
end with
[/vba]

Автор - Саня
Дата добавления - 28.07.2016 в 12:53
китин Дата: Четверг, 28.07.2016, 12:53 | Сообщение № 5
Группа: Модераторы
Ранг: Экселист
Сообщений: 7013
Репутация: 1073 ±
Замечаний: 0% ±

Excel 2007;2010;2016
БД Access

SQL Server+StorageProc

на это денюшку не дают. :'(
за совет спасибо.пробую


Не судите очень строго:я пытаюсь научиться
ЯД 41001877306852
 
Ответить
Сообщение
БД Access

SQL Server+StorageProc

на это денюшку не дают. :'(
за совет спасибо.пробую

Автор - китин
Дата добавления - 28.07.2016 в 12:53
_Boroda_ Дата: Четверг, 28.07.2016, 13:13 | Сообщение № 6
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Нууу, довольно спорно. Копипаст заменить на .value = .value? На маленьких диапазонах - возможно, а вот на больших ...


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеНууу, довольно спорно. Копипаст заменить на .value = .value? На маленьких диапазонах - возможно, а вот на больших ...

Автор - _Boroda_
Дата добавления - 28.07.2016 в 13:13
Manyasha Дата: Четверг, 28.07.2016, 13:34 | Сообщение № 7
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
Игорь, попробуйте так (массивы вместо формул и куча циклов):
[vba]
Код
Sub СУММПР_2()
'    t = Timer
    Dim lLastRow As Long
    
    Dim lLastCol As Long
    Dim data, result, lr As Long, i As Long, j As Long, k As Long, d As Long
    Dim sh1 As Worksheet, sh2 As Worksheet
    Set sh1 = ThisWorkbook.Sheets("План")
    Set sh2 = ThisWorkbook.Sheets("состав")
    lLastCol = Cells(31, Columns.Count).End(xlToLeft).Column
    With sh2
        .Range("B1:AG30").ClearContents
        lr = sh1.Cells(Rows.Count, 2).End(xlUp).Row
        data = sh1.Range("a15:gb" & lr).Value
        ReDim result(UBound(data) - 1, UBound(data, 1) - 1)
        
        For i = 4 To UBound(data)
            For j = 2 To 33 'по столбцам b31:ag31
                If data(i, 3) = .Cells(31, j) Then
                    'Вместо формулы для 1-й строки
                    result(0, j - 2) = result(0, j - 2) + data(i, 7) + data(i, 8) + data(i, 9)
                    'Вместо формул для диапазона b2:ag29
                    For d = 2 To 29             'по строкам с датами на листе состав
                        For k = 16 To 183       'по столбцам $P$18:$GA$800 на листе план
                            If data(2, k) = "СБ" And data(1, k) = .Cells(d, 1) Then
                    result(d - 1, j - 2) = result(d - 1, j - 2) + data(i, k)
                            End If
                        Next k
                    Next d
                    'Вместо формулы для 30-й строки
                    result(29, j - 2) = result(29, j - 2) + data(i, 184)
                End If
            Next j
        Next i
        .Range("B1:AG30") = result
    End With
    'Дальше ничего не трогала
    Dim sh As Worksheet, r As Range
    If ActiveWindow.SelectedSheets.Count > 1 Then 'убираем нули после спецвставка( код от Ярослава)
        For Each sh In ActiveWindow.SelectedSheets
            Set r = sh.UsedRange
            r.Replace 0, "", xlWhole
        Next
    Else
        If MsgBox("Заменить 0 во всей книге?", vbYesNo) = vbNo Then
            If Selection.Count = 1 Then Set r = ActiveSheet.UsedRange Else Set r = Selection
            r.Replace 0, "", xlWhole
        Else
            For Each sh In ActiveWorkbook.Sheets
                Set r = sh.UsedRange
                r.Replace 0, "", xlWhole
            Next
        End If
    End If
'    Debug.Print Timer - t
End Sub
[/vba]
К сообщению приложен файл: 4430277-1.xlsm (82.9 Kb)


ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеИгорь, попробуйте так (массивы вместо формул и куча циклов):
[vba]
Код
Sub СУММПР_2()
'    t = Timer
    Dim lLastRow As Long
    
    Dim lLastCol As Long
    Dim data, result, lr As Long, i As Long, j As Long, k As Long, d As Long
    Dim sh1 As Worksheet, sh2 As Worksheet
    Set sh1 = ThisWorkbook.Sheets("План")
    Set sh2 = ThisWorkbook.Sheets("состав")
    lLastCol = Cells(31, Columns.Count).End(xlToLeft).Column
    With sh2
        .Range("B1:AG30").ClearContents
        lr = sh1.Cells(Rows.Count, 2).End(xlUp).Row
        data = sh1.Range("a15:gb" & lr).Value
        ReDim result(UBound(data) - 1, UBound(data, 1) - 1)
        
        For i = 4 To UBound(data)
            For j = 2 To 33 'по столбцам b31:ag31
                If data(i, 3) = .Cells(31, j) Then
                    'Вместо формулы для 1-й строки
                    result(0, j - 2) = result(0, j - 2) + data(i, 7) + data(i, 8) + data(i, 9)
                    'Вместо формул для диапазона b2:ag29
                    For d = 2 To 29             'по строкам с датами на листе состав
                        For k = 16 To 183       'по столбцам $P$18:$GA$800 на листе план
                            If data(2, k) = "СБ" And data(1, k) = .Cells(d, 1) Then
                    result(d - 1, j - 2) = result(d - 1, j - 2) + data(i, k)
                            End If
                        Next k
                    Next d
                    'Вместо формулы для 30-й строки
                    result(29, j - 2) = result(29, j - 2) + data(i, 184)
                End If
            Next j
        Next i
        .Range("B1:AG30") = result
    End With
    'Дальше ничего не трогала
    Dim sh As Worksheet, r As Range
    If ActiveWindow.SelectedSheets.Count > 1 Then 'убираем нули после спецвставка( код от Ярослава)
        For Each sh In ActiveWindow.SelectedSheets
            Set r = sh.UsedRange
            r.Replace 0, "", xlWhole
        Next
    Else
        If MsgBox("Заменить 0 во всей книге?", vbYesNo) = vbNo Then
            If Selection.Count = 1 Then Set r = ActiveSheet.UsedRange Else Set r = Selection
            r.Replace 0, "", xlWhole
        Else
            For Each sh In ActiveWorkbook.Sheets
                Set r = sh.UsedRange
                r.Replace 0, "", xlWhole
            Next
        End If
    End If
'    Debug.Print Timer - t
End Sub
[/vba]

Автор - Manyasha
Дата добавления - 28.07.2016 в 13:34
китин Дата: Четверг, 28.07.2016, 14:03 | Сообщение № 8
Группа: Модераторы
Ранг: Экселист
Сообщений: 7013
Репутация: 1073 ±
Замечаний: 0% ±

Excel 2007;2010;2016
Копипаст заменить на .value = .value

файл виснет напрочь. серый экран и моргает гад :D


Не судите очень строго:я пытаюсь научиться
ЯД 41001877306852
 
Ответить
Сообщение
Копипаст заменить на .value = .value

файл виснет напрочь. серый экран и моргает гад :D

Автор - китин
Дата добавления - 28.07.2016 в 14:03
SGerman Дата: Четверг, 28.07.2016, 14:12 | Сообщение № 9
Группа: Пользователи
Ранг: Участник
Сообщений: 97
Репутация: 4 ±
Замечаний: 20% ±

Excel 2003
на это денюшку не дают


Сейчас найти бесплатный SQL Server не проблема


Мудрость приходит со старостью. Но иногда старость приходит одна :)
 
Ответить
Сообщение
на это денюшку не дают


Сейчас найти бесплатный SQL Server не проблема

Автор - SGerman
Дата добавления - 28.07.2016 в 14:12
китин Дата: Четверг, 28.07.2016, 14:23 | Сообщение № 10
Группа: Модераторы
Ранг: Экселист
Сообщений: 7013
Репутация: 1073 ±
Замечаний: 0% ±

Excel 2007;2010;2016
Марина спасибо. немного быстрее. Но один маленький недостаток:В твоем коде с моим багажом(весьма скудным :'( ) знаний я вряд ли разберусь, что бы подправить его :D хотя бы в количестве столбцов: их у меня сейчас 700 и будут добавляться.Я почему и сделал поиск по последнему столбцу[vba]
Код
lLastCol = Cells(31, Columns.Count).End(xlToLeft).Column
[/vba]


Не судите очень строго:я пытаюсь научиться
ЯД 41001877306852


Сообщение отредактировал китин - Четверг, 28.07.2016, 14:23
 
Ответить
СообщениеМарина спасибо. немного быстрее. Но один маленький недостаток:В твоем коде с моим багажом(весьма скудным :'( ) знаний я вряд ли разберусь, что бы подправить его :D хотя бы в количестве столбцов: их у меня сейчас 700 и будут добавляться.Я почему и сделал поиск по последнему столбцу[vba]
Код
lLastCol = Cells(31, Columns.Count).End(xlToLeft).Column
[/vba]

Автор - китин
Дата добавления - 28.07.2016 в 14:23
Саня Дата: Четверг, 28.07.2016, 15:34 | Сообщение № 11
Группа: Друзья
Ранг: Ветеран
Сообщений: 1068
Репутация: 560 ±
Замечаний: 0% ±

XL 2016
узкое место в расчете, остальное не значимо

[vba]
Код
Sub СУММПР_1()
    Dim t As Single: t = Timer

    Dim lLastRow As Long
    Dim lLastCol As Long

    lLastCol = Cells(31, Columns.Count).End(xlToLeft).Column

    Sheets("состав").Range("B1").FormulaLocal = "=СУММПРОИЗВ(План!$G$18:$I$1000*(План!$C$18:$C$1000=состав!B$31))"    'вставляем формулу в 1 строку
    Range("B1").Select
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range(Cells(1, 2), Cells(1, lLastCol)), Type:=xlFillDefault    'копируем на весь диапазон
    Range(Cells(1, 2), Cells(1, lLastCol)).Select
    Selection.Copy    ' копируем
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False    'вставляем значения

    Debug.Print "1): " & Timer - t: t = Timer

    'Sheets("состав").Range("B2").FormulaLocal = _
     "=СУММПРОИЗВ(План!$P$18:$GA$800*(План!$P$16:$GA$16=""СБ"")*(План!$P$15:$GA$15=состав!$A2)*(состав!B$31=План!$C$18:$C$800))"    'вставляем формулу в 2 строку

    'Range("B2").Select
    'Selection.AutoFill Destination:=Range("B2:B29"), Type:=xlFillDefault
    'Range("B2:B29").Select
    'Selection.AutoFill Destination:=Range(Cells(2, 2), Cells(29, lLastCol)), Type:=xlFillDefault
    'Range(Cells(2, 2), Cells(29, lLastCol)).Select
    'Selection.Copy
    'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
     :=False, Transpose:=False    'вставляем значения
    
    With Range(Cells(2, 2), Cells(29, lLastCol))
        .FormulaR1C1 = _
        "=SUMPRODUCT(План!R18C16:R800C183*(План!R16C16:R16C183=""СБ"")*(План!R15C16:R15C183=состав!RC1)*(состав!R31C=План!R18C3:R800C3))"
        Debug.Print "2): " & Timer - t: t = Timer
        .Value = .Value
        Debug.Print "2): " & Timer - t: t = Timer
'        .Copy
'        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False    'вставляем значения
    End With
    'Debug.Print "2): " & Timer - t: t = Timer

    Sheets("состав").Range("B30").FormulaLocal = "=СУММПРОИЗВ(План!$GB$19:$GB$1000*(План!$C$19:$C$1000=состав!B$31))"    'вставляем формулу в 30 строку
    Range("B30").Select
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range(Cells(30, 2), Cells(30, lLastCol)), Type:=xlFillDefault    'копируем на весь диапазон
    Range(Cells(30, 2), Cells(30, lLastCol)).Select
    Selection.Copy  ' копируем
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False    'вставляем значения

    Debug.Print "3): " & Timer - t
    Debug.Print
    MsgBox "ok"
    '    Dim sh As Worksheet, r As Range
    '    If ActiveWindow.SelectedSheets.Count > 1 Then    'убираем нули после спецвставка( код от Ярослава)
    '        For Each sh In ActiveWindow.SelectedSheets
    '            Set r = sh.UsedRange
    '            r.Replace 0, "", xlWhole
    '        Next
    '    Else
    '        If MsgBox("Заменить 0 во всей книге?", vbYesNo) = vbNo Then
    '            If Selection.Count = 1 Then Set r = ActiveSheet.UsedRange Else Set r = Selection
    '            r.Replace 0, "", xlWhole
    '        Else
    '            For Each sh In ActiveWorkbook.Sheets
    '                Set r = sh.UsedRange
    '                r.Replace 0, "", xlWhole
    '            Next
    '        End If
    '    End If
End Sub
[/vba]
 
Ответить
Сообщениеузкое место в расчете, остальное не значимо

[vba]
Код
Sub СУММПР_1()
    Dim t As Single: t = Timer

    Dim lLastRow As Long
    Dim lLastCol As Long

    lLastCol = Cells(31, Columns.Count).End(xlToLeft).Column

    Sheets("состав").Range("B1").FormulaLocal = "=СУММПРОИЗВ(План!$G$18:$I$1000*(План!$C$18:$C$1000=состав!B$31))"    'вставляем формулу в 1 строку
    Range("B1").Select
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range(Cells(1, 2), Cells(1, lLastCol)), Type:=xlFillDefault    'копируем на весь диапазон
    Range(Cells(1, 2), Cells(1, lLastCol)).Select
    Selection.Copy    ' копируем
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False    'вставляем значения

    Debug.Print "1): " & Timer - t: t = Timer

    'Sheets("состав").Range("B2").FormulaLocal = _
     "=СУММПРОИЗВ(План!$P$18:$GA$800*(План!$P$16:$GA$16=""СБ"")*(План!$P$15:$GA$15=состав!$A2)*(состав!B$31=План!$C$18:$C$800))"    'вставляем формулу в 2 строку

    'Range("B2").Select
    'Selection.AutoFill Destination:=Range("B2:B29"), Type:=xlFillDefault
    'Range("B2:B29").Select
    'Selection.AutoFill Destination:=Range(Cells(2, 2), Cells(29, lLastCol)), Type:=xlFillDefault
    'Range(Cells(2, 2), Cells(29, lLastCol)).Select
    'Selection.Copy
    'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
     :=False, Transpose:=False    'вставляем значения
    
    With Range(Cells(2, 2), Cells(29, lLastCol))
        .FormulaR1C1 = _
        "=SUMPRODUCT(План!R18C16:R800C183*(План!R16C16:R16C183=""СБ"")*(План!R15C16:R15C183=состав!RC1)*(состав!R31C=План!R18C3:R800C3))"
        Debug.Print "2): " & Timer - t: t = Timer
        .Value = .Value
        Debug.Print "2): " & Timer - t: t = Timer
'        .Copy
'        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False    'вставляем значения
    End With
    'Debug.Print "2): " & Timer - t: t = Timer

    Sheets("состав").Range("B30").FormulaLocal = "=СУММПРОИЗВ(План!$GB$19:$GB$1000*(План!$C$19:$C$1000=состав!B$31))"    'вставляем формулу в 30 строку
    Range("B30").Select
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range(Cells(30, 2), Cells(30, lLastCol)), Type:=xlFillDefault    'копируем на весь диапазон
    Range(Cells(30, 2), Cells(30, lLastCol)).Select
    Selection.Copy  ' копируем
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False    'вставляем значения

    Debug.Print "3): " & Timer - t
    Debug.Print
    MsgBox "ok"
    '    Dim sh As Worksheet, r As Range
    '    If ActiveWindow.SelectedSheets.Count > 1 Then    'убираем нули после спецвставка( код от Ярослава)
    '        For Each sh In ActiveWindow.SelectedSheets
    '            Set r = sh.UsedRange
    '            r.Replace 0, "", xlWhole
    '        Next
    '    Else
    '        If MsgBox("Заменить 0 во всей книге?", vbYesNo) = vbNo Then
    '            If Selection.Count = 1 Then Set r = ActiveSheet.UsedRange Else Set r = Selection
    '            r.Replace 0, "", xlWhole
    '        Else
    '            For Each sh In ActiveWorkbook.Sheets
    '                Set r = sh.UsedRange
    '                r.Replace 0, "", xlWhole
    '            Next
    '        End If
    '    End If
End Sub
[/vba]

Автор - Саня
Дата добавления - 28.07.2016 в 15:34
Manyasha Дата: Четверг, 28.07.2016, 15:58 | Сообщение № 12
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
поиск по последнему столбцу
вот в этой строчке заменить 33 на lLastCol
[vba]
Код
For j = 2 To 33 'по столбцам b31:ag31
[/vba]

немного быстрее

у меня на исходном файле за 1,5 сек. все общитал :(
А исходный вариант макроса и вариант от Сани от 10 до 12 сек.

Игорь, а обозначения на листе План (столбец С) могут повторяться?


ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщение
поиск по последнему столбцу
вот в этой строчке заменить 33 на lLastCol
[vba]
Код
For j = 2 To 33 'по столбцам b31:ag31
[/vba]

немного быстрее

у меня на исходном файле за 1,5 сек. все общитал :(
А исходный вариант макроса и вариант от Сани от 10 до 12 сек.

Игорь, а обозначения на листе План (столбец С) могут повторяться?

Автор - Manyasha
Дата добавления - 28.07.2016 в 15:58
китин Дата: Четверг, 28.07.2016, 16:13 | Сообщение № 13
Группа: Модераторы
Ранг: Экселист
Сообщений: 7013
Репутация: 1073 ±
Замечаний: 0% ±

Excel 2007;2010;2016
обозначения на листе План (столбец С) могут повторяться?

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


Не судите очень строго:я пытаюсь научиться
ЯД 41001877306852
 
Ответить
Сообщение
обозначения на листе План (столбец С) могут повторяться?

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

Автор - китин
Дата добавления - 28.07.2016 в 16:13
SLAVICK Дата: Четверг, 28.07.2016, 16:15 | Сообщение № 14
Группа: Модераторы
Ранг: Старожил
Сообщений: 2290
Репутация: 766 ±
Замечаний: 0% ±

2019
массивы вместо формул и куча циклов

Думаю еще парочки словарей не хватает. :D .
Кстати - не совсем понял почему:
[vba]
Код
ReDim result(UBound(data) - 1, UBound(data, 1) - 1)
[/vba]
Данные на 2-м листе не всегда будут = количеству строк на 1-м ;) .

Я почему и сделал поиск по последнему столбцу

Добавил размеры диапазона по посл. столбцу.

В твоем коде с моим багажом(весьма скудным )

НУ дык форум для того и есть чтоб учится разбираться yes .

у меня на исходном файле за 1,5 сек. все общитал

а у мну практически мгновенно. :D .

могут и часто.

так не договаривались . В примере такого нет - давайте пример с такими дублями.
К сообщению приложен файл: 7622154.xlsm (85.2 Kb)


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
массивы вместо формул и куча циклов

Думаю еще парочки словарей не хватает. :D .
Кстати - не совсем понял почему:
[vba]
Код
ReDim result(UBound(data) - 1, UBound(data, 1) - 1)
[/vba]
Данные на 2-м листе не всегда будут = количеству строк на 1-м ;) .

Я почему и сделал поиск по последнему столбцу

Добавил размеры диапазона по посл. столбцу.

В твоем коде с моим багажом(весьма скудным )

НУ дык форум для того и есть чтоб учится разбираться yes .

у меня на исходном файле за 1,5 сек. все общитал

а у мну практически мгновенно. :D .

могут и часто.

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

Автор - SLAVICK
Дата добавления - 28.07.2016 в 16:15
Manyasha Дата: Четверг, 28.07.2016, 16:38 | Сообщение № 15
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
почему:

ReDim result(UBound(data) - 1, UBound(data, 1) - 1)

потому что меня переклинило, я решила, что это диапазон 2-го листа :D
Ярослав, спасибо за проверку)) Конечно надо вот так:
[vba]
Код
ReDim result(29, lLastCol - 2)
[/vba]

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


ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщение
почему:

ReDim result(UBound(data) - 1, UBound(data, 1) - 1)

потому что меня переклинило, я решила, что это диапазон 2-го листа :D
Ярослав, спасибо за проверку)) Конечно надо вот так:
[vba]
Код
ReDim result(29, lLastCol - 2)
[/vba]

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

Автор - Manyasha
Дата добавления - 28.07.2016 в 16:38
Manyasha Дата: Четверг, 28.07.2016, 17:14 | Сообщение № 16
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
Изменила немного макрос SLAVICKа, учитываются повторы в столбце С на листе План.
К сообщению приложен файл: 7622154-1.xlsb (54.9 Kb)


ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеИзменила немного макрос SLAVICKа, учитываются повторы в столбце С на листе План.

Автор - Manyasha
Дата добавления - 28.07.2016 в 17:14
китин Дата: Среда, 03.08.2016, 12:00 | Сообщение № 17
Группа: Модераторы
Ранг: Экселист
Сообщений: 7013
Репутация: 1073 ±
Замечаний: 0% ±

Excel 2007;2010;2016
Ну наконец то добрался до тестирования. последний вариант отработал на УРА. мои объемы просчитал за 1,5 минуты. файл упал на 0,5 метра и больше не тормозит(почти). Огромное всем спасибо за помощь и терпение !!!


Не судите очень строго:я пытаюсь научиться
ЯД 41001877306852
 
Ответить
СообщениеНу наконец то добрался до тестирования. последний вариант отработал на УРА. мои объемы просчитал за 1,5 минуты. файл упал на 0,5 метра и больше не тормозит(почти). Огромное всем спасибо за помощь и терпение !!!

Автор - китин
Дата добавления - 03.08.2016 в 12:00
китин Дата: Среда, 03.08.2016, 12:49 | Сообщение № 18
Группа: Модераторы
Ранг: Экселист
Сообщений: 7013
Репутация: 1073 ±
Замечаний: 0% ±

Excel 2007;2010;2016
не. все таки вопрос вдогонку: а что прописать в код, что бы он срабатывал при любом изменении на листе " План"?


Не судите очень строго:я пытаюсь научиться
ЯД 41001877306852
 
Ответить
Сообщениене. все таки вопрос вдогонку: а что прописать в код, что бы он срабатывал при любом изменении на листе " План"?

Автор - китин
Дата добавления - 03.08.2016 в 12:49
_Boroda_ Дата: Среда, 03.08.2016, 13:03 | Сообщение № 19
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Игорь, ты точно уверен в том, что ты именно этого хочешь?
Если таки да, то ПКМ на ярлык листа План - Исходный код и туда вот это
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Sheets("состав").СУММПР_3
End Sub
[/vba]
К сообщению приложен файл: 7622154-1_1.xlsb (55.9 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеИгорь, ты точно уверен в том, что ты именно этого хочешь?
Если таки да, то ПКМ на ярлык листа План - Исходный код и туда вот это
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Sheets("состав").СУММПР_3
End Sub
[/vba]

Автор - _Boroda_
Дата добавления - 03.08.2016 в 13:03
китин Дата: Среда, 03.08.2016, 13:22 | Сообщение № 20
Группа: Модераторы
Ранг: Экселист
Сообщений: 7013
Репутация: 1073 ±
Замечаний: 0% ±

Excel 2007;2010;2016
Саша спасибо.
ты точно уверен
пока не знаю. Появилась такая мысль, благо лист План чисто мой и я могу тупо его сильно скрыть. а какие камни могут быть?
под
любом изменении на листе " План"

я имел ввиду замена там либо цифирок в рабочем диапазоне или полная замена этого диапазона путем вставки такой же таблицы, скопированной из другой книги


Не судите очень строго:я пытаюсь научиться
ЯД 41001877306852


Сообщение отредактировал китин - Среда, 03.08.2016, 13:22
 
Ответить
СообщениеСаша спасибо.
ты точно уверен
пока не знаю. Появилась такая мысль, благо лист План чисто мой и я могу тупо его сильно скрыть. а какие камни могут быть?
под
любом изменении на листе " План"

я имел ввиду замена там либо цифирок в рабочем диапазоне или полная замена этого диапазона путем вставки такой же таблицы, скопированной из другой книги

Автор - китин
Дата добавления - 03.08.2016 в 13:22
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Ускорить работу макроса нахождения кол-ва по трем условиям (Макросы/Sub)
  • Страница 1 из 2
  • 1
  • 2
  • »
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!