Сравнение диапазона при условиях

[Karamantak]

Доброй ночи всем.
Есть файл, в нем 3 листа, в лист1 - 4 столбца, в лист2 - 3 столбца, в лист3 - 2 столбца.

Условие "лист1(B=1)": если лист1(А:А)=лист2(А:А) то с лист2(B,C) необходимо заполнить данные в лист1(C,D), причем если в лист2(B,C) несколько строчек с одним и тем же номером, то нужна сумма этих данных.

Условие "лист1(B=2)": если лист1(А:А)=лист3(А:А) то с лист2(B) необходимо заполнить данные в лист1(С), причем если в лист3(B) несколько строчек с одним и тем же номером, то нужна сумма этих данных.

В приложенном файле в ячейках значение 1, значение 2, стоят экселевские формулы, но хотелось бы через макрос.

Такой вот код сделал, по примерам:

 Sub макрос()

Dim i As Integer
Dim k As Integer

i = 2

Do While Not (IsEmpty(Worksheets("Лист1").Cells(i, 1)))

    k = 2
    
    Do While Not (IsEmpty(Worksheets("Лист2").Cells(k, 2)))
           
If Worksheets("Лист1").Cells(i, 1) = Worksheets("Лист2").Cells(k, 1) Then
    If Worksheets("Лист1").Cells(i, 2) = 1 Then
        Worksheets("Лист1").Cells(i, 9) = Worksheets("Лист2").Cells(k, 2).Value
    End If
End If
If Worksheets("Лист1").Cells(i, 1) = Worksheets("Лист2").Cells(k, 1) Then
    If Worksheets("Лист1").Cells(i, 2) = 1 Then
        Worksheets("Лист1").Cells(i, 10).Value = Worksheets("Лист2").Cells(k, 3).Value
    End If
End If
If Worksheets("Лист1").Cells(i, 1) = Worksheets("Лист3").Cells(k, 1) Then
    If Worksheets("Лист1").Cells(i, 2) = 2 Then
        Worksheets("Лист1").Cells(i, 9) = Worksheets("Лист3").Cells(k, 2).Value
    End If
End If

 If Worksheets("Лист1").Cells(i, 1) = Worksheets("Лист2").Cells(k, 1) Then GoTo 1

    k = k + 1
    Loop
    
1 i = i + 1
Loop

End Sub

Так же сделал, по примерам, похожий:

Sub макроc2()

Dim a(), b(), i&, ii&, k&

a = Worksheets("Лист1").[a1].CurrentRegion.Value
    ReDim c(1 To UBound(a), 9 To 10)
b = Worksheets("Лист2").[a1].CurrentRegion.Value
d = Worksheets("Лист3").[a1].CurrentRegion.Value

For i = 1 To UBound(a)
    For ii = 1 To UBound(b)
        If a(i, 1) = b(ii, 1) Then
            If a(i, 2) = 1 Then
            c(i, 9) = b(ii, 2)
            c(i, 10) = b(ii, 3)
            Exit For
            End If
        End If
       
        Next ii, i
        
For i = 1 To UBound(a)
   For k = 1 To UBound(d)
        If a(i, 1) = d(k, 1) Then
            If a(i, 2) = 2 Then
            c(i, 9) = d(k, 2)
            Exit For
            End If
        End If
    
        Next k, i
        
Worksheets("Лист1").[g1].Resize(UBound(c), 2) = c

End Sub

Они оба работают, но берут только первое совпадение, а надо бы сумму этих совпадений.

Заранее благодарю!

[SAS888]

Можно так:

Sub макроc2()
    Dim a(), b(), c(), d(), i&, ii&, k&
    a = Sheets("Лист1").[a1].CurrentRegion.Value
    b = Sheets("Лист2").[a1].CurrentRegion.Value
    d = Sheets("Лист3").[a1].CurrentRegion.Value
    ReDim c(1 To UBound(a, 1), 9 To 10)
    For i = 1 To UBound(a)
        For ii = 1 To UBound(b)
            If a(i, 1) = b(ii, 1) Then
                If a(i, 2) = 1 Then
                    c(i, 9) = c(i, 9) + b(ii, 2): c(i, 10) = c(i, 10) + b(ii, 3)
                End If
            End If
        Next
    Next
    For i = 1 To UBound(a)
        For k = 1 To UBound(d)
            If a(i, 1) = d(k, 1) Then If a(i, 2) = 2 Then c(i, 9) = c(i, 9) + d(k, 2)
        Next
    Next
    Sheets("Лист1").[g1].Resize(UBound(c, 1), 2).Value = c
End Sub

Но я бы не советовал использовать метод CurrentRegion. Потому, что если в таблице данных встретится пустая строка, то в массив будут помещены не все данные.

[Karamantak]

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

Но я бы не советовал использовать метод CurrentRegion. Потому, что если в таблице данных встретится пустая строка, то в массив будут помещены не все данные.

Большое спасибо за ответ. А не подскажете метод если не этот? Так действительно если есть пустые строки, то работает не так как надо.

[SAS888]

Вместо

a = Sheets("Лист1").[A1].CurrentRegion.Value

используйте

With Sheets("Лист1"): a = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value: End With

Для других листов аналогично.

[Karamantak]

With Sheets("Лист1"): a = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value: End With

Благодарю за ответ. Попробовал по разному, но все равно ругается.

With Sheets("Лист1"): a = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
    For i = 2 To UBound(a)
  
    With Sheets("Лист2"): b = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
        For ii = 1 To UBound(b)
            If a(i, 1) = b(ii, 1) Then
                If a(i, 2) = 1 Then
                    a(i, 9) = b(ii, 2)
                    a(i, 10) = a(i, 10) + b(ii, 3)
                End If
            End If
            
        Next ii
        End With
    Next i
    
End With

то ругается там где желтым выделено, то красным...

как задать массив куда надо заполнять?

Извиняюсь, если уж совсем напрягаю, но как-то самостоятельно не получается разобраться...

Хотелось бы вообще на счет каждого оператора и строчки спросить, но неудобно, а в справочниках и учебниках и т.д. и т.п. либо шибко заумно и непонятно пишут, либо совсем не то, что надо.
Читал Уокенбаха, так у него хоть и просто описано, но для новичка не совсем понятно.
Конкретно для своей задачи, так и вовсе нигде не нашел.

[RAN.]

А почему бы и не ругаться?
Оба массива (a и b) имеют по 2 столбца.
А вы пытаетесь загнать\прочитать то третий, то девятый, то десятый...

[SAS888]

Будьте внимательны при обращении к элементам массивов. Правильно указывайте индексы размерности.
Например, для Вашего примера из вложения (пост №1) нужно так:

Sub макроc2()
    Dim a(), b(), c(), d(), i&, ii&, k&
    With Sheets("Лист1"): a = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value: End With
    With Sheets("Лист2"): b = .Range("A1:C" & .Cells(Rows.Count, 1).End(xlUp).Row).Value: End With
    With Sheets("Лист3"): d = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value: End With
    ReDim c(1 To UBound(a, 1), 1 To 2)
    For i = 1 To UBound(a, 1)
        For ii = 1 To UBound(b, 1)
            If a(i, 1) = b(ii, 1) Then
                If a(i, 2) = 1 Then
                    c(i, 1) = c(i, 1) + b(ii, 2): c(i, 2) = c(i, 2) + b(ii, 3)
                End If
            End If
        Next
    Next
    For i = 1 To UBound(a)
        For k = 1 To UBound(d)
            If a(i, 1) = d(k, 1) Then If a(i, 2) = 2 Then c(i, 1) = c(i, 1) + d(k, 2)
        Next
    Next
    Sheets("Лист1").[g1].Resize(UBound(c, 1), 2).Value = c
End Sub

В прикрепленном вложении находится Ваш файл с моим макросом и подробными комментариями.

[Karamantak]

SAS888, огромное спасибо за помощь, да еще и с подробными комментариями!!! Стало намного понятнее что к чему.