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

[dwmair23]

Спасибо огромное за помощь.

[bothke]

Сообщение от 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

а если так не получается? есть еще какой-то вариант?

[dwmair23]

.Value = WorksheetFunction.Transpose(di.keys)

на данной строчке возникает ошибка, если длина строки более 255 символов.

Возможно ли обойти данное ограничение?

[dwmair23]

У самого метода "WorksheetFunction.Transpose" есть ограничения я так понимаю.

[dwmair23]

Вроде как можно избежать ограничений, если использовать пользовательскую функцию "TransposeArray":

Sub ПримерИспользования()
 ИсходныйМассив = ActiveSheet.UsedRange.Offset(1).Value
 ТранспонированныйМассив = TransposeArray(ИсходныйМассив)
End Sub

Вот код самой функции:

Function TransposeArray(ByVal arr As Variant) As Variant
     ' Пользовательская функция для транспонирования массива
    Dim tempArray As Variant
     ReDim tempArray(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
     For X = LBound(arr, 2) To UBound(arr, 2)
         For Y = LBound(arr, 1) To UBound(arr, 1)
             tempArray(X, Y) = arr(Y, X)
         Next Y
     Next X
     TransposeArray = tempArray
End Function

[dwmair23]

Теперь собственно вопрос - как функцию "TransposeArray" внедрить в такой вот код?

Option Explicit

Sub Dw()
Dim di As Object, i&, j&, x
Dim lCol As Long
Dim n1 As Variant
    
  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("B2", .Cells(.Rows.Count, 2).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 - 2).Formula = _
    "=IFERROR(VLOOKUP($A3,INDIRECT(""'""&C$2&""'!B:C""),2,),""-"")"
    
 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"
 
End Sub

[Aleksandr H.]

Какой вариант пробовали?

.Value = TransposeArray(di.keys )

или

.Value = TransposeArray(di.keys ).value

[dwmair23]

По всяко-разному пробовал.