Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос для Суммеслимн в памяти, Суммеслимн из другого листа
 
#1
03.11.2024 09:52:21
Здравствуйте Все,

Есть код Суммеслимн, но он работает только для одного листа, т.е. и диапазон суммирование и условие находятся на одном листе.

Как, сделать, чтобы суммировал диапазон из другого листа?

Вот код, который нужно исправить.

Файл с кодом в приложении.

Код
Sub SIMIFSINARRAY2() 
Dim SH1 As Worksheet, SH2 As Worksheet, I1 As Variant, I2 As Variant, ARR As Variant, R1 As Long, R2 As Long
Dim I As Long, J As Long, pCount As Long, D As Object

  Set SH1 = Sheets("22")
  R1 = SH1.Range("A" & Cells.Rows.Count).End(xlUp).Row
  I1 = SH1.Range("A2:J" & R1).Value
  
  Set SH2 = Sheets("33")
  R2 = SH2.Range("H" & Cells.Rows.Count).End(xlUp).Row
  I2 = SH2.Range("H2:J" & R2).Value
  
  
  ReDim ARR(1 To UBound(I1, 1), 1 To 1)
  ReDim ARR(1 To UBound(I2, 1), 1 To 1)
  Set D = CreateObject("Scripting.Dictionary")

  For I = 1 To R2 - 1
    If Not D.Exists(UCase(I2(I, 8 & I2(I, 9))) Then
        For J = 1 To R1 - 1
            If UCase(I2(I, 8) = UCase(I1(J, 1)) And _
                   UCase(I2(I, 9)) = UCase(I1(J, 2)) Then
                pCount = pCount + I1(J, 3)
            End If
        Next J
        D(UCase(I2(I, 8 & I2(I, 9))) = pCount
        ARR(I, 1) = pCount: pCount = 0
    Else
        ARR(I, 1) = D(UCase(I2(I, 8 & SH2(I, 9)))
    End If
  Next
  SH2.Range("J2").Resize(UBound(ARR, 1), 1).Value = ARR
End Sub
 
 
 
#2
03.11.2024 09:55:30
Всё. Вопрос снят. Только что заметил свою ошибку.

Если, в коде что то не нужное, или можно улучшить. Буду рад всем замечаниям.
Изменено: Шерзод Маткаримов - 03.11.2024 09:58:42
 
 
 
#3
03.11.2024 10:05:58
Возник другой вопрос, по этому же коду. При суммировании, отбрасывает копейки.

Добавил этот код перед выгрузкой, но он не исправил проблему
Код
SH2.Range("J2").Resize(UBound(ARR, 1), 1).NumberFormat = "@"

Помогите исправить.
 
 
 
#4
03.11.2024 11:45:21
Цитата
Шерзод Маткаримов написал:
отбрасывает копейки.
- потому что pCount As Long
Измените на Double
 
 
 
#5
03.11.2024 12:08:34
Hugo, Спасибо огромное. Работает.
 
 
 
#6
03.11.2024 12:32:10
А можно этот код, как то ускорить? Протестил на 100 000 строк, выполнилось за 2 мин.
 
 
 
#7
03.11.2024 14:35:54
Цитата
Шерзод Маткаримов написал:
А можно этот код, как то ускорить?
- дайте рабочий код в файле и посмотрим.
 
 
 
#8
03.11.2024 15:08:16
Время выполнения сократилось до 15 сек на 100 000 строк.

Хотелось бы ускорить еще.
 
 
 
#9
03.11.2024 15:20:08
Шерзод Маткаримов, ну а макрос, работающий с этими данными где?
Ну и конечно расскажите что хотите сделать, по файлу совершенно непонятно.
P.S. Ещё по задаче - т.к. названия там в примере длиной аж до 245 символов, типа
ПРИТОЧНАЯ УСТАНОВКА П2 (ИСП.ВНУТРЕННЕЕ) ПО ТИПУ НОВОВЕНТ М50-30 "НЗВЗ ВОЛГОПРОМВЕНТИЛЯЦИЯ". LОБЩ-1300 М3/Н. (ОБСЛУЖ.СПРАВА). ЛЕТО: Т-(НАР.В.) 40°С; Т-(В.В.) +24°С. ЗИМА: Т-(НАР.В.) -14°С; Т-(В.В.) +23°С. ВЕНТИЛЯТОР НА ПОДАЧУ В СЕТЬ: 500РА 4120Х7
то думаю есть смысл класть в словарь не это, а например хэш этого непотребства в виде
092ae16797f39ce678e190b551d34fc3
Да, чуть займёт время, но зато словарь будет компактнее. шевелиться будет быстрее. Ну раз нет каких-то ID/
И кстати если эти хэши добавить рядом на лист - то и ВПР можно будет применять (наверняка там в 100к есть длиной когда уже не летит ВПР), когда/если вдруг понадобится.
Изменено: Hugo - 03.11.2024 16:29:21
 
 
 
#10
03.11.2024 17:33:09
Забыл макрос, когда переносил данные в отдельный файл.

Сейчас на отдельном листе идёт пересчёт с формулами и результат переносится в нужный лист. Там суммеслимн на 6 столбцах и 3000 строк. Этот лист весит 350 кб. и наверняка влияет на скорость всего файла. Хотел, проверить как будет, если полностью сделать макросом.
 
 
 
#11
03.11.2024 18:15:33
Шерзод Маткаримов, там не используется вообще словарь, зачем он там?
И вот тут корректировали да недокорректировали - зачем два раза одно проверять? ((
Код
            If UCase(I2(I, 1)) = UCase(I1(J, 1)) Then
            If UCase(I2(I, 1)) = UCase(I1(J, 1)) And _


Да и тут лишняя строка
Код
  ReDim ARR(1 To UBound(I1, 1), 1 To 1)
  ReDim ARR(1 To UBound(I2, 1), 1 To 1)

У меня отрабатывает за 8 секунд.
Сейчас гляну что можно ускорить.

P.S. По логике процесса на втором листе дублей быть не должно, я буду основываться на этом. Результат будет только у одного из дублей.
Изменено: Hugo - 03.11.2024 18:22:22
 
 
 
#12
03.11.2024 18:37:37
Ну вот такой на примере отрабатывает за 0 секунд ))
Код

Sub SIMIFSINARRAY3() 'super tare, super fast

Dim T As Double: T = Now
Dim SH1 As Worksheet, SH2 As Worksheet, I1 As Variant, I2 As Variant, ARR As Variant, R1 As Long, R2 As Long
Dim i As Long, D As Object, tmp$, x&

  Set SH1 = Sheets("22")
  R1 = SH1.Range("A" & Cells.Rows.Count).End(xlUp).Row
  I1 = SH1.Range("A2:J" & R1).Value
  
  Set SH2 = Sheets("33")
  R2 = SH2.Range("H" & Cells.Rows.Count).End(xlUp).Row
  I2 = SH2.Range("H2:J" & R2).Value
  
  ReDim ARR(1 To UBound(I2, 1), 1 To 1)
  
  Set D = CreateObject("Scripting.Dictionary"): D.comparemode = 1
  
  For i = 1 To UBound(I2)
    D.Item(I2(i, 1) & I2(i, 2)) = i
  Next
  
  For i = 1 To UBound(I1)
  If I1(i, 4) > 4 Then
    tmp = I1(i, 1) & I1(i, 2)
    If D.exists(tmp) Then
        x = D.Item(tmp)
        ARR(x, 1) = ARR(x, 1) + I1(i, 3)
    End If
  End If
  Next
  
SH2.Range("J2").Resize(UBound(ARR, 1), 1).Value = ARR
MsgBox Now - T

End Sub


Делал задачу как понял, есть отличия от того кода
 
 
 
#13
03.11.2024 18:58:20
Цитата
написал:
If UCase(I2(I, 1)) = UCase(I1(J, 1)) Then
Я принципы работы массивов, и вообще VBA плохо знаю. Я просто поэкспериментировал, и этот код сократил время на 4 сек.

Цитата
написал:
У меня отрабатывает за 8 секунд.
У меня Win10/Excel16

Цитата
написал:
Сейчас гляну что можно ускорить
Спасибо.
 
 
 
#14
03.11.2024 19:03:51
Hugo, Супер. Проверил на 100 тыс. строк. Моментально обработал.

Спасибо огромное.
 
 
 
#15
03.11.2024 19:21:19
Шерзод Маткаримов, проверьте результат.
Этот код записывает суммы только последнему из дублей. Есть там дубли как в примере?
 
 
 
#16
03.11.2024 19:28:19
Hugo, Проверил. Не критично. Всё как надо. В листе где суммируется итоги, не будут дублей. Спасибо.
 
 
 
#17
04.11.2024 14:01:28
Здравствуйте Hugo и все специалисты,

Помогите исправить ошибку.

Эти строки кода выдают ошибку run-time error '6' Overflow
Код
ARR(X, 6) = ARR(X, 7) / ARR(X, 1)
ARR(X, 8) = ARR(X, 9) / ARR(X, 1)
ARR(X, 10) = ARR(X, 11) / ARR(X, 1)


Код
Sub SIMIFSINARRAY3()

Dim T As Double: T = Now
Dim SH1 As Worksheet, SH2 As Worksheet, I1 As Variant, I2 As Variant, ARR As Variant, R1 As Long, R2 As Long
Dim I As Long, D As Object, TMP$, X&

Set SH1 = Sheets("22")
R1 = SH1.Range("D" & Cells.Rows.Count).End(xlUp).Row
I1 = SH1.Range("D14:AH" & R1).Value
  
Set SH2 = Sheets("33")
R2 = SH2.Range("D" & Cells.Rows.Count).End(xlUp).Row
I2 = SH2.Range("C25:O" & R2).Value
  
    ReDim ARR(1 To UBound(I2, 1), 1 To 11)
      
    Set D = CreateObject("Scripting.Dictionary"): D.comparemode = 1
  
    For I = 1 To UBound(I2)
        D.Item(I2(I, 1) & I2(I, 2)) = I
    Next
  
    For I = 1 To UBound(I1)
      If I1(I, 31) > 4 And I1(I, 31) < 9 Then
        TMP = I1(I, 1) & I1(I, 2)
        If D.exists(TMP) Then
            X = D.Item(TMP)
            ARR(X, 2) = ARR(X, 2) + I1(I, 4)
            ARR(X, 4) = ARR(X, 4) + I1(I, 6)
            ARR(X, 7) = ARR(X, 7) + I1(I, 19)
            ARR(X, 9) = ARR(X, 9) + I1(I, 20)
            ARR(X, 11) = ARR(X, 11) + I1(I, 6)
            If ARR(X, 7) = 0 Then
            ARR(X, 7) = ARR(X, 7) + I1(I, 6)
            ARR(X, 9) = ARR(X, 9) + I1(I, 6)
            End If
            ARR(X, 1) = ARR(X, 4) / ARR(X, 2)
            ARR(X, 3) = ARR(X, 2) - (ARR(X, 6) - ARR(X, 8))
            ARR(X, 5) = ARR(X, 4) - (ARR(X, 7) - ARR(X, 9))
            
            'ARR(X, 6) = ARR(X, 7) / ARR(X, 1) 'Строка с ошибкой run-time error '6' Overflow
            'ARR(X, 8) = ARR(X, 9) / ARR(X, 1)
            'ARR(X, 10) = ARR(X, 11) / ARR(X, 1)
        End If
      End If
    Next
    SH2.Range("E25").Resize(UBound(ARR, 1), 11).Value = ARR


MsgBox Now - T
End Sub
 
 
 
#18
04.11.2024 14:07:57
Что в этот момент в ARR(X, 1) и ARR(X, 4)? Вангую что 0
 
 
 
#19
04.11.2024 14:13:12
Цитата
написал:
Что в этот момент в ARR(X, 1) и ARR(X, 4)? Вангую что 0
Все кроме этих 3х заполняются. Числа делятся на числа, нулей нет.
 
 
 
#20
04.11.2024 14:15:36
           

Попробовал так. Сработало.
Код
If ARR(X, 1) <> 0 Then ARR(X, 6) = ARR(X, 7) / ARR(X, 1)
If ARR(X, 1) <> 0 Then ARR(X, 8) = ARR(X, 9) / ARR(X, 1)
If ARR(X, 1) <> 0 Then ARR(X, 10) = ARR(X, 11) / ARR(X, 1)
 
 
 
#21
05.11.2024 10:18:49
Здравствуй уважаемые,

Можно ли сделать так, чтобы суммировались если столбцы и строки отвечают условиям.
В строках идут наименования, а сверху в столбцах даты.

Файл с примером прикрепляю.
Изменено: Шерзод Маткаримов - 05.11.2024 14:38:17
 
 
 
Страницы: 1
Наверх