Поиск значений из нескольких листов в первом листе

[dwmair23]

Здравствуйте.

Исходные данные таковы (файл во вложении):
1. Имеется файл состоящий из 4-х листов (количество листов может быть и 5, и 10, и 20).
2. На первом листе ("ОсновнойЛист") имеются данные, состоящие из 2-х столбцов. Нас интересует только первый столбец "A" (текст).
3. Имеется пачка новых листов ("НовыйЛист1", "НовыйЛист2", "НовыйЛист3" и т.д.), состоящие из 2-х столбцов "A" (текст) и "B" (числа).

Задача:
1. Найти все значения из первого столбца "А" листов "НовыйЛист1", "НовыйЛист2", "НовыйЛист3" в столбце "A" листа "ОсновнойЛист".
2. Если текст найден (по сути мы найдем нужную нам строку), то на листе "ОсновнойЛист" записать в строке в соседнюю ячейку (для "НовыйЛист1" это будет 3-й столбец "C", для "НовыйЛист2" это будет 4-й столбец "D" и т.д.) от найденного нами текста значение соседней ячейки (число, из например "НовыйЛист1"), текст которой мы искали.
Возможно немного сумбурно написано, но открыв вложенный файл станет понятнее.
3. Если текст не найден, то на листе "ОсновнойЛист" в конец первого столбца "А" записать этот текст. Выделить его красным цветом. И опять записать в соседнюю ячейку значение соседней ячейки (число, из например "НовыйЛист1"), текст которой мы искали.

Простой формулой здесь точно не отделаться. А моих навыков программирования точно не хватит для решения данной задачи.

[Aleksandr H.]

1. Добавить в конец столба А листа Основной, с листов НовыйЛист1..N те позиции которых еще нету в столбце А.
2. прописать ВПР/СУММЕСЛИ для поиска значений из каждого листа.

Ваших навыков программирования хватит чтобы организовать 3 цикла для поиска "нового" наименования?

Цикл1: НовыйЛист1..НовыйЛистN
   Цикл2: От Строка3 до СтрокаПоследняя НовыйЛистХ
      Цикл3: От Строка3 до СтрокаПоследняя ОсновнойЛист

upd
или другой вариант поиска "новых" наименований

Option Explicit

Sub geee()
    Dim d As Object
    Dim i As Integer
    Dim sh As Integer
    Set d = CreateObject("Scripting.Dictionary")
    With Sheets(1)
        i = 3
        Do While .Cells(i, "A") <> ""
            If Not d.Exists(.Cells(i, "A")) Then
                d.Add Trim(.Cells(i, "A")), Trim(.Cells(i, "A"))
            End If
            i = i + 1
        Loop
    End With

    Dim r As Integer: r = i + 1
    For sh = 2 To Sheets.Count
        With Sheets(sh)
            i = 3
            Do While .Cells(i, "A") <> ""
                If Not d.Exists(Trim(.Cells(i, "A"))) Then
                    d.Add Trim(.Cells(i, "A")), Trim(.Cells(i, "A"))
                    Sheets(1).Cells(r, "A") = Trim(.Cells(i, "A")): r = r + 1
                End If
                i = i + 1
            Loop
        End With
    Next
End Sub

[Казанский]

Sub Dw()
Dim di As Object, i&, j&, x
  Set di = CreateObject("scripting.dictionary")
  di.comparemode = vbTextCompare
  Range("C:Z").ClearContents
  For i = 2 To Worksheets.Count
    With Worksheets(i)
      Worksheets(1).Cells(2, i + 1) = .Name
      For Each x In .Range("A3", .Cells(.Rows.Count, 1).End(xlUp)).Value2
        di(x) = 0
      Next
    End With
  Next
  j = Cells(Rows.Count, 1).End(xlUp).Row
  For Each x In Range("A3:A" & j).Value2
    If di.exists(x) Then di.Remove x
  Next
  If di.Count Then
    With Cells(j + 1, 1).Resize(di.Count)
      .Value = WorksheetFunction.Transpose(di.keys)
      .Font.Color = vbRed
    End With
  Else
    MsgBox "Новых наименований нет", vbInformation
  End If
  Range("C3").Resize(j - 2 + di.Count, i - 1).Formula = _
    "=IFERROR(VLOOKUP($A3,INDIRECT(""'""&C$2&""'!A:B""),2,),"""")"
End Sub

[dwmair23]

Спасибо огромное. Именно то, что нужно.

Я пытался делать просто вот такой формулой

=ЕСЛИ(ЕНД(ВПР(A3:A32;'Новый лист 1'!$A$3:$B$32;1;ЛОЖЬ));0;ВПР(A3:A32 ;'Новый лист 1'!$A$3:$B$32;2;ЛОЖЬ))

Не сочтите за наглость, но еще вопрос:
1. Последним столбцом на листе "ОсновнойЛист" делать суммирование новых записанных чисел в каждой строке. Столбец будет называться "Всего".
2. Самым последним столбцом делать разность: столбец "Всего" минус столбец "Количество" (это столбец "B").

После этих правок всё будет просто идеально.

[dwmair23]

Я так понимаю нужно будет организовать еще 2 цикла.

[Казанский]

Нет, две строки для вставки формул. А м.б. одна. Доберусь до компа - напишу.

[dwmair23]

Хорошо. Буду ждать.

[dwmair23]

Последний столбец ищу вот так:

Dim lCol As Long
lCol = Worksheets(1).Cells(3, Columns.Count).End(xlToLeft).Column

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

[Aleksandr H.]

    Cells(3, lCol + 1).Resize(j - 2 + di.Count, 1).FormulaR1C1 = "=SUM(RC3:RC[-1])"
    Cells(3, lCol + 2).Resize(j - 2 + di.Count, 1).FormulaR1C1 = "=rc[-1]-rc2"

[dwmair23]

Вот так оставлю:

lCol = Worksheets(1).Cells(2, Columns.Count).End(xlToLeft).Column
Worksheets(1).Cells(2, lCol + 1) = "Всего"
Worksheets(1).Cells(2, lCol + 2) = "Результат"

' n1 = Split(Cells(1, lCol).Address, "$")(1)
' MsgBox ("Последний столбец: " & n1 & lCol), vbInformation

Cells(3, lCol + 1).Resize(j - 2 + di.Count, 1).FormulaR1C1 = "=SUM(RC3:RC[-1])"
Cells(3, lCol + 2).Resize(j - 2 + di.Count, 1).FormulaR1C1 = "=rc[-1]-rc2"