[URL=#]?[/URL]       1  2  3  4  5  6  7  8  9  10  11  12  13  14  15  16  17  18  19  20  21  22  23  24  25      Sub   Макрос1()    Dim   lr   As   Long  , n   As   Long  , m   As   Long  , arr1   As   Variant  , arr2   As   Variant  , arr3   As   Variant  , sh   As   Worksheet, s   As   String    Set   Dict = CreateObject(  "Scripting.Dictionary"  )    Set   Dict1 = CreateObject(  "Scripting.Dictionary"  )    lr = Worksheets(  "Свод"  ).Cells(Rows.Count, 2).  End  (xlUp).Row    arr1 = Worksheets(  "Свод"  ).Range(  "A2:C"   & lr).Value    ReDim   arr3(LBound(arr1)   To   UBound(arr1), 1   To   1)    For   Each   sh   In   Sheets          If   sh.Name <>   "Свод"   Then   Dict1.Add sh.Name, sh.Name    Next    For   n = LBound(arr1)   To   UBound(arr1)          If   Not   Dict1.Exists(arr1(n, 2))   Then              MsgBox   "Лист с именем: "  ""   & arr1(n, 2) &   ""  " отсутствует"          Else              lr = Worksheets(arr1(n, 2)).Cells(Rows.Count, 4).  End  (xlUp).Row              arr2 = Worksheets(arr1(n, 2)).Range(  "D1:D"   & lr)              For   m = LBound(arr2)   To   UBound(arr2)                  If   Not   Dict.Exists(arr2(m, 1))   Then   Dict.Add arr2(m, 1), arr2(m, 1)              Next   m              arr3(n, 1) = Join(Dict.Keys,   "; "  )              Dict.RemoveAll          End   If    Next   n    Worksheets(  "Свод"  ).Range(  "D2"  ).Resize(UBound(arr3)).Value = arr3    End   Sub   

    [URL=#]?[/URL]       1  2  3  4  5  6  7  8  9  10  11  12  13  14  15  16      Sub   Макрос1()    Dim   lr   As   Long  , n   As   Long  , m   As   Long  , arr1   As   Variant  , arr2   As   Variant  , arr3   As   Variant    Set   Dict = CreateObject(  "Scripting.Dictionary"  )    arr1 = Worksheets(  "Свод"  ).Range(  "A2:C4"  ).Value    ReDim   arr3(LBound(arr1)   To   UBound(arr1), 1   To   1)    For   n = LBound(arr1)   To   UBound(arr1)          lr = Worksheets(arr1(n, 2)).Cells(Rows.Count, 4).  End  (xlUp).Row          arr2 = Worksheets(arr1(n, 2)).Range(  "D1:D"   & lr)          For   m = LBound(arr2)   To   UBound(arr2)              If   Not   Dict.Exists(arr2(m, 1))   Then   Dict.Add arr2(m, 1), arr2(m, 1)          Next   m          arr3(n, 1) = Join(Dict.Keys,   "; "  )          Dict.RemoveAll    Next   n    Worksheets(  "Свод"  ).Range(  "D2:D4"  ).Value = arr3    End   Sub   

    [URL=#]?[/URL]       1      =ОБЪЕДИНИТЬ(  "; "  ;1;УНИК(ДВССЫЛ(  "'"  &B2&  "'!D:D"  )))