Страницы: 1
RSS
Список значений с определенного столбца в ексель на отдельный лист в виде свода, Список значений с определенного столбца в ексель на отдельный лист в виде свода в автоматическом режиме с обновлениями
 
Добрый день!
Помогите, пожалуйста, решить проблему =)

Как можно вытащить данные из столбца D каждого листа в автоматическом режиме с автоматическим обновлением при изменении?
Ячейки в столбце D одного листа могут иметь разные значения, например К.03.1.; П.09.1.; О.04.7., значения могут повторяться, еще ячейки могут быть просто пустыми

Пример во вложении. Буду очень признательна)
 
Если 2019 и выше
В ячейку D2
Код
=ОБЪЕДИНИТЬ("; ";1;УНИК(ДВССЫЛ("'"&B2&"'!D:D")))
Изменено: Msi2102 - 19.05.2022 17:36:49
 
Вариант в PQ (обновляется каждую минуту, обновляется при открытии, можно макросом привязать обновление по изменению):
Код
let
  filePath     = Table.FirstValue ( Excel.CurrentWorkbook(){[ Name = "filePath" ]}[Content] ),
  file         = Excel.Workbook ( File.Contents ( filePath ) ),
  filterSheets = Table.SelectRows ( file, each [Name] <> "Свод" and [Kind] = "Sheet" and [Hidden] = false ),
  transform    = Table.TransformColumns ( filterSheets, { { "Data", ( x ) => Text.Combine ( List.Sort ( List.Distinct ( x[Column4] ) ), "; " ), type text } } ),
  rename       = Table.RenameColumns ( transform, { { "Name", "Наименование листа" }, { "Data", "Данные столбца ""D""" } } ),
  addIndex     = Table.AddIndexColumn ( rename, "№ п/п", 1, 1 ),
  addSheetN    = Table.AddColumn ( addIndex, "Лист", each "Лист" & Text.From ( [#"№ п/п"] ), type text ),
  needClmns    = Table.SelectColumns ( addSheetN, { "№ п/п", "Лист", "Наименование листа", "Данные столбца ""D""" } )
in
  needClmns
 
Цитата
написал:
Если 2019 и выше
В ячейку D2
Код
    [URL=#]?[/URL]       1      =ОБЪЕДИНИТЬ(  "; "  ;1;УНИК(ДВССЫЛ(  "'"  &B2&  "'!D:D"  )))   
 
Добрый день!
Спасибо за ответ. Но excel 2010 года - не работает =(
 
Забыла дописать, что excel 10.

PQ не установлен. Может быть есть возможность формулами вытащить информацию? Или макрос?
 
Макрос:
Код
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  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   
 
А как добавлять листы? При добавлении листов не заполняет новые строки
 
Огромное спасибо всем за помощь.

Если можно, еще уточню информацию по файлу...

Макрос работает красиво, но файл может расширяться до большого количества листов (40-60), наименования листов могут быть разными, не только "Лист...". И при добавлении нового листа в книгу и в свод, можно сделать так, чтобы и с этого нового листа поступала информация по столбцу D.

Сейчас при добавлении листа ничего не происходит, данные по нему не заполняются =(
 
Нужно, чтобы на листе "Свод" в столбце В (названия листов) ниже значений ничего не было
Код
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
Изменено: Msi2102 - 20.05.2022 15:00:41
 
Цитата
написал:
Нужно, чтобы на листе "Свод" в столбце В (названия листов) ниже значений ничего не было
Код
    [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   
 
Спасибо, спасибо, спасибо Вам за помощь!!! Все работает =)
Страницы: 1
Наверх