Ускорение макроса поиска и суммирования - Microsoft Office Excel - Страница 2

DiemonStar · 01.10.2012, 09:16

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

Код:

  Dim Tabl As Range, Corp As Range
  Set Tabl = Intersect(Sheets("Таблица").Range("E29:DX627"), Sheets("Таблица").Range("A29:A627").SpecialCells(xlCellTypeBlanks).EntireRow)
  I = 5
  Set Corp = Tabl.Columns(1).EntireColumn
  While I <= Tabl.Columns.Count
    Set Corp = Union(Corp, Tabl.Columns(I).EntireColumn)
    I = I + 4
  Wend
  Set Corp = Intersect(Corp, Tabl)
  Corp.SpecialCells(xlCellTypeConstants).Offset(, 1).Select

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

staniiislav · 01.10.2012, 11:22

Цитата:

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

может, как-то так

Код:

Sub find_()
'Dim tm!: tm = Timer
Dim r As Range, adr As String, i&, j&, k&
Dim x: x = Range("D6:D22").Value
ReDim y(1 To UBound(x), 1 To 1)
With Range("E29:DV627")
    For i = 1 To UBound(x)
        If Len(x(i, 1)) Then
            Set r = .Find(What:=x(i, 1), LookAt:=xlWhole)
            If Not r Is Nothing Then
                adr = r.Address
                Do
                    If r(1, 0) > 0 Then
                        j = r(1, 0) + 4: k = i + 3
                        y(i, 1) = Sheets("Расценка").Cells(j, k).Value
                        Exit Do
                    End If
                    Set r = .FindNext(r)
                Loop While r.Address <> adr
            End If
        End If
    Next i
End With
Range("EL6").Resize(i - 1).Value = y
'MsgBox Timer - tm
End Sub

Спасибо за помощь, но к сожалению немного не так...
Необходимо чтобы если например 201 операция и корпус 1 = 618,19, а если далее нашло по операции 201 корпус допустим 22= 786,20+618,19=1404,39. Но если операция 201 корпус 1 = 618,19, затем операция 201 корпус 1 = 618,19, то дубликаты не должно суммировать 201 = 618,19.
Если добавляю еще цикл по корпусам, то значительно время работы увеличивается

staniiislav · 01.10.2012, 11:58

Цитата:

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

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

Код:

  Dim Tabl As Range, Corp As Range
  Set Tabl = Intersect(Sheets("Таблица").Range("E29:DX627"), Sheets("Таблица").Range("A29:A627").SpecialCells(xlCellTypeBlanks).EntireRow)
  I = 5
  Set Corp = Tabl.Columns(1).EntireColumn
  While I <= Tabl.Columns.Count
    Set Corp = Union(Corp, Tabl.Columns(I).EntireColumn)
    I = I + 4
  Wend
  Set Corp = Intersect(Corp, Tabl)
  Corp.SpecialCells(xlCellTypeConstants).Offset(, 1).Select

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

Спасибо за помощь! Посмотрите пожалуйста еще раз пример 29 и 30 число.
Пытаюсь найти по каждой операции по всем корпусам сумму выполненных операций
Допустим по 201 операции ищи все корпуса (с 1 по 33). Находи допустим 1 корпус ищим по нему сумму на листе расценка (запоминаем сумму), ищим дальше, находи опять первый корпус (не суммируем т.к. 1 корпус уже был), далее находим 2 корпус (ищим сумму по 2 корпусу на листе расценка), суммируем суммы всех найденных корпусов (без дубликатов)
Переходим к следующей операции.
В пример 29 и 30 числа показано как это чудо будет заполнятся (в столбце "EL7:EL20") показано как суммируется.
Честно сказать вижу как работает код, но не понимаю как можно сделать под себя (((

staniiislav · 01.10.2012, 12:02

запарился, вот файлик

nilem · 01.10.2012, 12:33

наверное, ertert нужен

Код:

Sub ertert()
Dim x, R, i&, j&, s$, t(), d#, k
x = Sheets("Расценка").Range("D2:T2").Value
R = Sheets("Расценка").Range("B5:T37").Value
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x, 2)
        If Len(x(1, i)) Then .Item(x(1, i)) = Array(i + 2, s, d)
    Next i
    x = Sheets("Таблица").Range("E29:DV627").Value
    For i = 1 To UBound(x, 1)
        For j = 2 To UBound(x, 2)
            If .Exists(x(i, j)) Then
                If x(i, j - 1) > 0 Then
                    s = x(i, j - 1): t = .Item(x(i, j))
                    If InStr(t(1), s) = 0 Then
                        t(1) = t(1) & "~" & s
                        t(2) = t(2) + R(s, t(0))
                        .Item(x(i, j)) = t
    End If: End If: End If: Next j, i
    i = 0: ReDim x(16, 0)
    For Each k In .keys
        x(i, 0) = .Item(k)(2): i = i + 1
    Next k
End With
Sheets("Таблица").Range("EL6:EL22").Value = x
End Sub

как ни крути, а все равно получается словарь

staniiislav · 01.10.2012, 12:50

Цитата:

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

наверное, ertert нужен

Код:

Sub ertert()
Dim x, R, i&, j&, s$, t(), d#, k
x = Sheets("Расценка").Range("D2:T2").Value
R = Sheets("Расценка").Range("B5:T37").Value
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x, 2)
        If Len(x(1, i)) Then .Item(x(1, i)) = Array(i + 2, s, d)
    Next i
    x = Sheets("Таблица").Range("E29:DV627").Value
    For i = 1 To UBound(x, 1)
        For j = 2 To UBound(x, 2)
            If .Exists(x(i, j)) Then
                If x(i, j - 1) > 0 Then
                    s = x(i, j - 1): t = .Item(x(i, j))
                    If InStr(t(1), s) = 0 Then
                        t(1) = t(1) & "~" & s
                        t(2) = t(2) + R(s, t(0))
                        .Item(x(i, j)) = t
    End If: End If: End If: Next j, i
    i = 0: ReDim x(16, 0)
    For Each k In .keys
        x(i, 0) = .Item(k)(2): i = i + 1
    Next k
End With
Sheets("Таблица").Range("EL6:EL22").Value = x
End Sub

как ни крути, а все равно получается словарь

Блин, ОГОНЬ!!!
Не понимаю как это чудо работает, но работает быстро и правильно!!!
Спасибо ОГРОМНЕЙШЕЕ nilem!!!

П.С. Огромное спасибо ВСЕМ участника данной темы! Понемногу начинаю понимать как работают массивы... но еще далековато мне для понимания связи словарей с массивами (как они совместно так быстро работают)

nilem · 01.10.2012, 14:24

упс, обнаружился недочет. Вот здесь нужно добавить тильду:

Код:

If InStr(t(1), "~" & s) = 0 Then

staniiislav · 01.10.2012, 14:38

Цитата:

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

упс, обнаружился недочет. Вот здесь нужно добавить тильду:

Код:

If InStr(t(1), "~" & s) = 0 Then

Спасибо большое.
если будет, время прокомментируйте пожалуйста код

DiemonStar · 01.10.2012, 18:49

Цитата:

Спасибо за помощь! Посмотрите пожалуйста еще раз пример 29 и 30 число.
Пытаюсь найти по каждой операции по всем корпусам сумму выполненных операций
Допустим по 201 операции ищи все корпуса (с 1 по 33). Находи допустим 1 корпус ищим по нему сумму на листе расценка (запоминаем сумму), ищим дальше, находи опять первый корпус (не суммируем т.к. 1 корпус уже был), далее находим 2 корпус (ищим сумму по 2 корпусу на листе расценка), суммируем суммы всех найденных корпусов (без дубликатов)
Переходим к следующей операции.
В пример 29 и 30 числа показано как это чудо будет заполнятся (в столбце "EL7:EL20") показано как суммируется.
Честно сказать вижу как работает код, но не понимаю как можно сделать под себя (((

Если честно, опять много слов и мало конкретики. Например, не сказано, как всё это с датами взаимодействует: считает для каждой конкретной даты или "всквозную".
Т.е., по-сути, вам нужны суммы расценок корпусов по каждой операции? или суммы расценок операций по каждому из корпусов?

DiemonStar · 01.10.2012, 20:08

Код:

Sub Test()
  Dim Tabl As Range, Oper As Range
  
  Set Tabl = Intersect(Range("E29:DX627"), Range("A29:A627").SpecialCells(xlCellTypeBlanks).EntireRow)
  I = 6
  Set Oper = Tabl.Columns(2).EntireColumn
  While I <= Tabl.Columns.Count
    Set Oper = Union(Oper, Tabl.Columns(I).EntireColumn)
    I = I + 4
  Wend
  Set Oper = Intersect(Oper, Tabl)
  
  Set DctOper = CreateObject("Scripting.Dictionary")
  I = 1
  For Each CC In Sheets("Ðàñöåíêè").Range("D2:R2").Cells
    DctOper.Add CC.Text, I
    I = I + 1
  Next CC
 
  Arr = Sheets("Ðàñöåíêè").Range("D5:R37").Cells
  ReDim Rslt(1 To UBound(Arr, 2))
  
  For Each CC In Oper.SpecialCells(xlCellTypeConstants)
    If DctOper.Exists(CC.Text) Then
      I = DctOper(CC.Text)
    Else
      I = -1
    End If
      J = CC.Offset(, -1).Value
    If (I > 0) And (J > 0) Then
      Rslt(I) = Rslt(I) + Arr(J, I)
      Arr(J, I) = 0
    End If
  Next CC
  
  For Each Sm In Rslt
    If Sm > 0 Then
      MsgBox Sm
  End If: Next Sm
End Sub

Вот так, например, решается в одном цикле) с использованием одного словаря...

01.10.2012, 09:16	#11
DiemonStar Старожил Регистрация: 08.02.2012 Сообщений: 2,173	Если честно, у Вас слишком много данных для перебора - оттуда и тормоза. можете попробовать работать только с заполненными ячейками. Например, так: Код: `Dim Tabl As Range, Corp As Range Set Tabl = Intersect(Sheets("Таблица").Range("E29:DX627"), Sheets("Таблица").Range("A29:A627").SpecialCells(xlCellTypeBlanks).EntireRow) I = 5 Set Corp = Tabl.Columns(1).EntireColumn While I <= Tabl.Columns.Count Set Corp = Union(Corp, Tabl.Columns(I).EntireColumn) I = I + 4 Wend Set Corp = Intersect(Corp, Tabl) Corp.SpecialCells(xlCellTypeConstants).Offset(, 1).Select` Данный код выделяет лишь лишь ячейки с операциями, для которых заполнено значение корпуса. з.ы. чего вы конкретно хотите добиться, я так до конца и не понял, поэтому адаптируйте данный код под свои нужды сами. з.з.ы. Для ускорения поиска индексов в таблице с расценками я бы воспользовался словарями. Правильно поставленная задача - три четверти решения. Последний раз редактировалось DiemonStar; 01.10.2012 в 09:19.

01.10.2012, 14:24	#17
nilem Форумчанин Регистрация: 25.04.2010 Сообщений: 616	упс, обнаружился недочет. Вот здесь нужно добавить тильду: Код: `If InStr(t(1), "~" & s) = 0 Then`

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Ускорение макроса Copy Paste	Ivan Dulin	Microsoft Office Excel	1	21.05.2012 19:51
Ускорение макроса	ymnuhj	Microsoft Office Excel	5	12.05.2012 00:48
макрос для поиска позиций и вывода данных на лист поиска	mr-111	Microsoft Office Excel	12	13.03.2012 15:03
Ускорение работы макроса Cell Name.	Foxx	Microsoft Office Word	0	26.02.2012 21:38
Запуск макроса с параметрами из другого макроса	Saladin	Microsoft Office Excel	2	19.01.2009 09:43