Dim i&, j As Variant With ActiveSheet.UsedRange With Intersect(.Offset(5), .Cells) arr = .Value For i = LBound(arr, 1) To UBound(arr, 1) For Each j In Array(17, 26) Macr = arr(i, j - .Column + 1) If Macr <> "" Then Application.Run Macr Application.Wait Now + #12:00:05 AM# End If Next j, i End With End With
[/vba]или[vba]
Код
Dim r As Range, col As Variant With ActiveSheet.UsedRange With Intersect(.Offset(5), .Cells) For Each r In .Rows For Each col In Array("Q", "Z") Macr = r.Columns(col).Value If Macr <> "" Then Application.Run Macr Application.Wait Now + #12:00:05 AM# End If Next col, r End With End With
[/vba]
Здравствуйте. [vba]
Код
Dim i&, j As Variant With ActiveSheet.UsedRange With Intersect(.Offset(5), .Cells) arr = .Value For i = LBound(arr, 1) To UBound(arr, 1) For Each j In Array(17, 26) Macr = arr(i, j - .Column + 1) If Macr <> "" Then Application.Run Macr Application.Wait Now + #12:00:05 AM# End If Next j, i End With End With
[/vba]или[vba]
Код
Dim r As Range, col As Variant With ActiveSheet.UsedRange With Intersect(.Offset(5), .Cells) For Each r In .Rows For Each col In Array("Q", "Z") Macr = r.Columns(col).Value If Macr <> "" Then Application.Run Macr Application.Wait Now + #12:00:05 AM# End If Next col, r End With End With
В каждой книге таблица с столбцами подписаными по первой строке.
я понял, что у вас несколько файлов с листами, именование столбцов на которых нужно привести к общему порядку. И написал макрос, который это делает, тока часть кода забыл выложить. Добавил в ваш файл макрос, добавил в него комментарии. [vba]
Код
'--------------------------------------------------------------------------------------- ' Модуль : modFilenames ' Автор : EducatedFool (Игорь) Дата: 13.04.2011 ' Разработка макросов для Excel, Word, CorelDRAW. Быстро, профессионально, недорого. ' http://excelvba.ru/ ICQ: 5836318 Skype: ExcelVBA.ru ' Реквизиты для оплаты: http://excelvba.ru/payments '--------------------------------------------------------------------------------------- Option Explicit Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _ Optional ByVal SearchDeep As Long = 999) As Collection ' Получает в качестве параметра путь к папке FolderPath, ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением) ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются). ' Возвращает коллекцию, содержащую полные пути найденных файлов ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO) Dim fso As Object
Set FilenamesCollection = New Collection ' создаём пустую коллекцию Set fso = CreateObject("Scripting.FileSystemObject") ' создаём экземпляр FileSystemObject GetAllFileNamesUsingFSO FolderPath, Mask, fso, FilenamesCollection, SearchDeep ' поиск Set fso = Nothing: Application.StatusBar = False ' очистка строки состояния Excel End Function
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef fso, _ ByRef FileNamesColl As Collection, ByVal SearchDeep As Long) ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO ' перебор папок осуществляется в том случае, если SearchDeep > 1 ' добавляет пути найденных файлов в коллекцию FileNamesColl Dim curfold As Object, fil As Object, sfol As Object On Error Resume Next: Set curfold = fso.GetFolder(FolderPath) If Not curfold Is Nothing Then ' если удалось получить доступ к папке
' раскомментируйте эту строку для вывода пути к просматриваемой ' в текущий момент папке в строку состояния Excel Application.StatusBar = "Поиск в папке: " & FolderPath
For Each fil In curfold.Files ' перебираем все файлы в папке FolderPath If fil.Name Like "*" & Mask And Left(fil.Name, 1) <> "~" Then FileNamesColl.Add fil.Path Next SearchDeep = SearchDeep - 1 ' уменьшаем глубину поиска в подпапках If SearchDeep Then ' если надо искать глубже For Each sfol In curfold.SubFolders ' ' перебираем все подпапки в папке FolderPath GetAllFileNamesUsingFSO sfol.Path, Mask, fso, FileNamesColl, SearchDeep Next End If Set fil = Nothing: Set curfold = Nothing ' очищаем переменные End If End Function
[/vba]
[vba]
Код
Option Explicit Sub AdjustColmns() Dim con As Object, ColFiles As Collection, AL As Object Dim wb As Workbook, sh As Worksheet, r As Range Dim sFilePath As Variant, sColName As Variant Dim sFolderPath$, c$, ver$, i&, calc&, b As Boolean With Application With .FileDialog(4) 'диалоговое окно выбора папки .AllowMultiSelect = False 'выбрать можно только одну папку .InitialFileName = CreateObject("Shell.Application").Namespace(5).self.Path & "\" 'при запуске диалога отобразить папку Мои доокументы .Title = "Выберите папку с файлами" 'заголовок диалогового окна sel: If .Show = False Then 'если папка не выбрана (закрыли или нажали Отмена) If MsgBox("Ничего не выбрано. Повторить?", vbYesNo) = vbYes Then 'запрос на повтор выбора GoTo sel 'нажали Да, открываем диалоговое окно еще раз Else Exit Sub 'нажали Нет, останавливаем выполнение макроса End If End If 'записываем путь к выбранной папке sFolderPath = .SelectedItems(1) & "\" End With
Set AL = CreateObject("system.collections.arraylist") 'объект ArrayList, в него будем собирать заголовки столбцов Set con = CreateObject("adodb.Connection") 'ADODB подключение, будем его использовать для сбора заголовков столбцов
'пишем в коллекцию пути всех excel книг из выбранной папки Set ColFiles = FilenamesCollection(sFolderPath, "*.xls*")
'перебираем пути файлов в коллекции For Each sFilePath In ColFiles On Error Resume Next 'если файл открыт, сохраняем его .Workbooks(Replace(sFilePath, sFolderPath, "")).Save On Error GoTo 0 'определяем тип файла по последней букве расширения Select Case Right(sFilePath, 1) Case "s": ver = "8.0" Case "x": ver = "12.0 xml" Case "m": ver = "12.0 macro" Case "b": ver = "12.0" End Select 'подлючаемся к файлу con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _ sFilePath & ";Mode=Read;Extended Properties=""excel " & ver & ";HDR=YES;IMEX=1;"";" 'перебиреаем значения поля COLUMN_NAME из схемы adSchemaColumns For Each sColName In con.OpenSchema(4).getrows(, , 3) c = Replace(sColName, "$", "") 'если значение еще не добавлено в AL, то добавляем If Not AL.contains(c) Then AL.Add c Next 'закрываем подключение con.Close Next AL.Sort 'сортируем полученный список заголовков столбцов .ScreenUpdating = 0: .EnableEvents = 0: calc = .Calculation: .Calculation = xlCalculationManual 'перебираем пути файлов в коллекции For Each sFilePath In ColFiles On Error Resume Next 'пробуем подключиться к открытой книге Set wb = .Workbooks(Replace(sFilePath, sFolderPath, "")) On Error GoTo 0
If wb Is Nothing Then 'если книга не была открыта 'открываем ее Set wb = .Workbooks.Open(sFilePath) Else b = True End If With wb
For Each sh In .Sheets ' перебираем листы i = 1 For Each sColName In AL 'перебираем значения из списка заголовков With sh.Rows(1) ' работаем с первой строкой листа 'ищем заголовок Set r = .Find(sColName, , , xlWhole, , , False, , False) If r Is Nothing Then ' если не найдено 'добавляем заголовок справа .End(xlToRight).Offset(, 1) = sColName Set r = .End(xlToRight) End If If r.Column <> i Then 'если номер столбца с искомым заголовком не равен позиции заголовка в AL 'перемещаем столбец в нужную позицию r.EntireColumn.Cut: .Columns(i).Insert Shift:=xlToRight End If i = i + 1 End With Next sColName, sh 'если книга была открыта макросом, закрываем ее с сохранением изменений If Not b Then .Close True End With Set wb = Nothing Next .ScreenUpdating = 1: .EnableEvents = 1: .Calculation = calc End With Set AL = Nothing: Set con = Nothing: Set r = Nothing: Set ColFiles = Nothing End Sub
В каждой книге таблица с столбцами подписаными по первой строке.
я понял, что у вас несколько файлов с листами, именование столбцов на которых нужно привести к общему порядку. И написал макрос, который это делает, тока часть кода забыл выложить. Добавил в ваш файл макрос, добавил в него комментарии. [vba]
Код
'--------------------------------------------------------------------------------------- ' Модуль : modFilenames ' Автор : EducatedFool (Игорь) Дата: 13.04.2011 ' Разработка макросов для Excel, Word, CorelDRAW. Быстро, профессионально, недорого. ' http://excelvba.ru/ ICQ: 5836318 Skype: ExcelVBA.ru ' Реквизиты для оплаты: http://excelvba.ru/payments '--------------------------------------------------------------------------------------- Option Explicit Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _ Optional ByVal SearchDeep As Long = 999) As Collection ' Получает в качестве параметра путь к папке FolderPath, ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением) ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются). ' Возвращает коллекцию, содержащую полные пути найденных файлов ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO) Dim fso As Object
Set FilenamesCollection = New Collection ' создаём пустую коллекцию Set fso = CreateObject("Scripting.FileSystemObject") ' создаём экземпляр FileSystemObject GetAllFileNamesUsingFSO FolderPath, Mask, fso, FilenamesCollection, SearchDeep ' поиск Set fso = Nothing: Application.StatusBar = False ' очистка строки состояния Excel End Function
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef fso, _ ByRef FileNamesColl As Collection, ByVal SearchDeep As Long) ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO ' перебор папок осуществляется в том случае, если SearchDeep > 1 ' добавляет пути найденных файлов в коллекцию FileNamesColl Dim curfold As Object, fil As Object, sfol As Object On Error Resume Next: Set curfold = fso.GetFolder(FolderPath) If Not curfold Is Nothing Then ' если удалось получить доступ к папке
' раскомментируйте эту строку для вывода пути к просматриваемой ' в текущий момент папке в строку состояния Excel Application.StatusBar = "Поиск в папке: " & FolderPath
For Each fil In curfold.Files ' перебираем все файлы в папке FolderPath If fil.Name Like "*" & Mask And Left(fil.Name, 1) <> "~" Then FileNamesColl.Add fil.Path Next SearchDeep = SearchDeep - 1 ' уменьшаем глубину поиска в подпапках If SearchDeep Then ' если надо искать глубже For Each sfol In curfold.SubFolders ' ' перебираем все подпапки в папке FolderPath GetAllFileNamesUsingFSO sfol.Path, Mask, fso, FileNamesColl, SearchDeep Next End If Set fil = Nothing: Set curfold = Nothing ' очищаем переменные End If End Function
[/vba]
[vba]
Код
Option Explicit Sub AdjustColmns() Dim con As Object, ColFiles As Collection, AL As Object Dim wb As Workbook, sh As Worksheet, r As Range Dim sFilePath As Variant, sColName As Variant Dim sFolderPath$, c$, ver$, i&, calc&, b As Boolean With Application With .FileDialog(4) 'диалоговое окно выбора папки .AllowMultiSelect = False 'выбрать можно только одну папку .InitialFileName = CreateObject("Shell.Application").Namespace(5).self.Path & "\" 'при запуске диалога отобразить папку Мои доокументы .Title = "Выберите папку с файлами" 'заголовок диалогового окна sel: If .Show = False Then 'если папка не выбрана (закрыли или нажали Отмена) If MsgBox("Ничего не выбрано. Повторить?", vbYesNo) = vbYes Then 'запрос на повтор выбора GoTo sel 'нажали Да, открываем диалоговое окно еще раз Else Exit Sub 'нажали Нет, останавливаем выполнение макроса End If End If 'записываем путь к выбранной папке sFolderPath = .SelectedItems(1) & "\" End With
Set AL = CreateObject("system.collections.arraylist") 'объект ArrayList, в него будем собирать заголовки столбцов Set con = CreateObject("adodb.Connection") 'ADODB подключение, будем его использовать для сбора заголовков столбцов
'пишем в коллекцию пути всех excel книг из выбранной папки Set ColFiles = FilenamesCollection(sFolderPath, "*.xls*")
'перебираем пути файлов в коллекции For Each sFilePath In ColFiles On Error Resume Next 'если файл открыт, сохраняем его .Workbooks(Replace(sFilePath, sFolderPath, "")).Save On Error GoTo 0 'определяем тип файла по последней букве расширения Select Case Right(sFilePath, 1) Case "s": ver = "8.0" Case "x": ver = "12.0 xml" Case "m": ver = "12.0 macro" Case "b": ver = "12.0" End Select 'подлючаемся к файлу con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _ sFilePath & ";Mode=Read;Extended Properties=""excel " & ver & ";HDR=YES;IMEX=1;"";" 'перебиреаем значения поля COLUMN_NAME из схемы adSchemaColumns For Each sColName In con.OpenSchema(4).getrows(, , 3) c = Replace(sColName, "$", "") 'если значение еще не добавлено в AL, то добавляем If Not AL.contains(c) Then AL.Add c Next 'закрываем подключение con.Close Next AL.Sort 'сортируем полученный список заголовков столбцов .ScreenUpdating = 0: .EnableEvents = 0: calc = .Calculation: .Calculation = xlCalculationManual 'перебираем пути файлов в коллекции For Each sFilePath In ColFiles On Error Resume Next 'пробуем подключиться к открытой книге Set wb = .Workbooks(Replace(sFilePath, sFolderPath, "")) On Error GoTo 0
If wb Is Nothing Then 'если книга не была открыта 'открываем ее Set wb = .Workbooks.Open(sFilePath) Else b = True End If With wb
For Each sh In .Sheets ' перебираем листы i = 1 For Each sColName In AL 'перебираем значения из списка заголовков With sh.Rows(1) ' работаем с первой строкой листа 'ищем заголовок Set r = .Find(sColName, , , xlWhole, , , False, , False) If r Is Nothing Then ' если не найдено 'добавляем заголовок справа .End(xlToRight).Offset(, 1) = sColName Set r = .End(xlToRight) End If If r.Column <> i Then 'если номер столбца с искомым заголовком не равен позиции заголовка в AL 'перемещаем столбец в нужную позицию r.EntireColumn.Cut: .Columns(i).Insert Shift:=xlToRight End If i = i + 1 End With Next sColName, sh 'если книга была открыта макросом, закрываем ее с сохранением изменений If Not b Then .Close True End With Set wb = Nothing Next .ScreenUpdating = 1: .EnableEvents = 1: .Calculation = calc End With Set AL = Nothing: Set con = Nothing: Set r = Nothing: Set ColFiles = Nothing End Sub
Option Explicit Sub AdjustColmns() Dim AL As Object, oWsh As Worksheet, r As Range, sColName As Variant, i&, calc& Set AL = CreateObject("system.collections.arraylist") 'объект ArrayList, в него будем собирать заголовки столбцов With Application .ScreenUpdating = 0: .EnableEvents = 0: calc = .Calculation: .Calculation = xlCalculationManual With ThisWorkbook 'книга, из которой запущен макрос For Each oWsh In .Sheets ' перебираем листы книги 'перебираем области диапазона непустых ячеек из первой строки листа For Each r In oWsh.UsedRange.Rows(1).SpecialCells(2, 23).Areas For Each sColName In r.Value 'перебираем значения из ячеек из области 'если значение еще не добавлено в AL, то добавляем If Not AL.contains(sColName) Then AL.Add sColName Next sColName, r, oWsh AL.Sort 'сортируем полученный список заголовков столбцов For Each oWsh In .Sheets ' перебираем листы i = 1 For Each sColName In AL 'перебираем значения из списка заголовков With oWsh.Rows(1) ' работаем с первой строкой листа 'ищем заголовок Set r = .Find(sColName, , , xlWhole, , , False, , False) If r Is Nothing Then ' если не найдено 'добавляем заголовок справа .End(xlToRight).Offset(, 1) = sColName Set r = .End(xlToRight) End If If r.Column <> i Then 'если номер столбца с искомым заголовком не равен позиции заголовка в AL 'перемещаем столбец в нужную позицию r.EntireColumn.Cut: .Columns(i).Insert Shift:=xlToRight End If i = i + 1 End With Next sColName, oWsh End With .ScreenUpdating = 1: .EnableEvents = 1: .Calculation = calc End With Set AL = Nothing: Set r = Nothing End Sub
Option Explicit Sub AdjustColmns() Dim AL As Object, oWsh As Worksheet, r As Range, sColName As Variant, i&, calc& Set AL = CreateObject("system.collections.arraylist") 'объект ArrayList, в него будем собирать заголовки столбцов With Application .ScreenUpdating = 0: .EnableEvents = 0: calc = .Calculation: .Calculation = xlCalculationManual With ThisWorkbook 'книга, из которой запущен макрос For Each oWsh In .Sheets ' перебираем листы книги 'перебираем области диапазона непустых ячеек из первой строки листа For Each r In oWsh.UsedRange.Rows(1).SpecialCells(2, 23).Areas For Each sColName In r.Value 'перебираем значения из ячеек из области 'если значение еще не добавлено в AL, то добавляем If Not AL.contains(sColName) Then AL.Add sColName Next sColName, r, oWsh AL.Sort 'сортируем полученный список заголовков столбцов For Each oWsh In .Sheets ' перебираем листы i = 1 For Each sColName In AL 'перебираем значения из списка заголовков With oWsh.Rows(1) ' работаем с первой строкой листа 'ищем заголовок Set r = .Find(sColName, , , xlWhole, , , False, , False) If r Is Nothing Then ' если не найдено 'добавляем заголовок справа .End(xlToRight).Offset(, 1) = sColName Set r = .End(xlToRight) End If If r.Column <> i Then 'если номер столбца с искомым заголовком не равен позиции заголовка в AL 'перемещаем столбец в нужную позицию r.EntireColumn.Cut: .Columns(i).Insert Shift:=xlToRight End If i = i + 1 End With Next sColName, oWsh End With .ScreenUpdating = 1: .EnableEvents = 1: .Calculation = calc End With Set AL = Nothing: Set r = Nothing End Sub
Sub Овал1_Щелчок() Dim r As Range, col As Variant With ActiveSheet.UsedRange With Intersect(.Offset(5), .Cells) For Each r In .Rows For Each col In Array("Q", "Z") With r.Columns(col) If .Value <> "" Then Macr = .Offset(, -7).Address(, , , 1) Application.Run .Value Application.Wait Now + #12:00:05 AM# End If End With Next col, r End With End With End Sub
[/vba]
[vba]
Код
Sub Овал1_Щелчок() Dim r As Range, col As Variant With ActiveSheet.UsedRange With Intersect(.Offset(5), .Cells) For Each r In .Rows For Each col In Array("Q", "Z") With r.Columns(col) If .Value <> "" Then Macr = .Offset(, -7).Address(, , , 1) Application.Run .Value Application.Wait Now + #12:00:05 AM# End If End With Next col, r End With End With End Sub
сделал вариант в Power Query, дабы освежить знания в памяти На Листе2 ПКМ по ячейке таблицы -> Обновить
[vba]
Код
let f1 = (a as table) as table=>let b=Table.ColumnNames(a){0} in Table.Sort(Table.SelectColumns(Table.Distinct(a, b), b), b), f2 = (a as text, optional b as any) as function=>let c = Splitter.SplitTextByDelimiter(a), d = Splitter.SplitTextByEachDelimiter({a}, 0, Logical.From(b)) in if b is null then c else d, f3 = (a as text) as text=>Text.Insert(a, Text.PositionOfAny(a, f4(0, 10)), "-"), f4 = (a as number, b as number) as list=>List.Transform(List.Numbers(a, b), each Text.From(_)), f5 = (a as table, b as any) as list=>let c = Table.ColumnNames(a), d = List.Count(c) in Table.ToRows(Table.FromColumns({c, List.Repeat({b}, d)})), f6=()=>each try Number.From(_) otherwise _, f7=(a as table)=>let b=Table.TransformColumns(a, f5(a, f6())), c=Table.Sort(b, f5(b, Order.Ascending)) in Table.TransformColumns(c, f5(c, Text.From)), f8 = (a as table, b as list, optional c as number) => let c = if c is null then 0 else c, d = try b{c}{2} otherwise b{c}{0}{0}, e = if b{c}{1} is list then Combiner.CombineTextByEachDelimiter else Combiner.CombineTextByDelimiter, f = Table.CombineColumns(a, b{c}{0}, e(b{c}{1}, 0), d) in if c+1 < List.Count(b) then @f8(f, b, c+1) else f, f9=(a as table, b as text, c as text)as table=>let d = Character.FromNumber(160), e = each Text.Replace(Text.Replace(Text.Trim(Text.Replace(Text.Replace(_, " ", d), c, " ")), " ", c), d, " ") in Table.TransformColumns(a, {b, e}), t0 = List.Transform({"Таблица1", "Таблица2"}, each Excel.CurrentWorkbook(){[Name=_]}[Content] as table), l1 = f4(4, List.Max(List.Transform(t5[4], each List.Count(Text.Split(_, "."))))), l2 = Table.ColumnNames(t0{0}), t1 = Table.SplitColumn(Table.TransformColumns(t0{0}, {l2{1}, f3}), l2{1}, f2("-"), f4(1, 2)), t2 = Table.AddIndexColumn(f8(f7(Table.TransformColumns(t1, f5(t1, f6()))), {{f4(1, 2), ""}}), "2", 0, 1), t3 = Table.Group(t2, {l2{0}}, {{"list", each Table.ToList(Table.SelectColumns(Table.Sort(_, {{"2", 0}}), "1")), type list}}), t4 = Table.SplitColumn(Table.SplitColumn(f1(t0{1}), l2{0}, f2("-", 0), {"1", "3"}), "1", f2("/", 0), f4(1, 2)), t5 = Table.SplitColumn(Table.TransformColumns(t4, {"3", each f3(_)}), "3", f2("-", 1), f4(3, 2)), t6 = f9(f8(f7(Table.SplitColumn(t5, "4", f2("."), l1)), {{l1, "."}, {f4(1, 4), {"/", "-"}, l2{0}}}), l2{0}, "."), t7 = Table.RenameColumns(Table.NestedJoin(t6, l2{0}, t3, l2{0}, "list", 1), {{"list", l2{1}}}), t8 = Table.ExpandListColumn(Table.TransformColumns(t7, {l2{1}, each try _[list]{0} otherwise {}}), l2{1}) in t8
[/vba]
сделал вариант в Power Query, дабы освежить знания в памяти На Листе2 ПКМ по ячейке таблицы -> Обновить
[vba]
Код
let f1 = (a as table) as table=>let b=Table.ColumnNames(a){0} in Table.Sort(Table.SelectColumns(Table.Distinct(a, b), b), b), f2 = (a as text, optional b as any) as function=>let c = Splitter.SplitTextByDelimiter(a), d = Splitter.SplitTextByEachDelimiter({a}, 0, Logical.From(b)) in if b is null then c else d, f3 = (a as text) as text=>Text.Insert(a, Text.PositionOfAny(a, f4(0, 10)), "-"), f4 = (a as number, b as number) as list=>List.Transform(List.Numbers(a, b), each Text.From(_)), f5 = (a as table, b as any) as list=>let c = Table.ColumnNames(a), d = List.Count(c) in Table.ToRows(Table.FromColumns({c, List.Repeat({b}, d)})), f6=()=>each try Number.From(_) otherwise _, f7=(a as table)=>let b=Table.TransformColumns(a, f5(a, f6())), c=Table.Sort(b, f5(b, Order.Ascending)) in Table.TransformColumns(c, f5(c, Text.From)), f8 = (a as table, b as list, optional c as number) => let c = if c is null then 0 else c, d = try b{c}{2} otherwise b{c}{0}{0}, e = if b{c}{1} is list then Combiner.CombineTextByEachDelimiter else Combiner.CombineTextByDelimiter, f = Table.CombineColumns(a, b{c}{0}, e(b{c}{1}, 0), d) in if c+1 < List.Count(b) then @f8(f, b, c+1) else f, f9=(a as table, b as text, c as text)as table=>let d = Character.FromNumber(160), e = each Text.Replace(Text.Replace(Text.Trim(Text.Replace(Text.Replace(_, " ", d), c, " ")), " ", c), d, " ") in Table.TransformColumns(a, {b, e}), t0 = List.Transform({"Таблица1", "Таблица2"}, each Excel.CurrentWorkbook(){[Name=_]}[Content] as table), l1 = f4(4, List.Max(List.Transform(t5[4], each List.Count(Text.Split(_, "."))))), l2 = Table.ColumnNames(t0{0}), t1 = Table.SplitColumn(Table.TransformColumns(t0{0}, {l2{1}, f3}), l2{1}, f2("-"), f4(1, 2)), t2 = Table.AddIndexColumn(f8(f7(Table.TransformColumns(t1, f5(t1, f6()))), {{f4(1, 2), ""}}), "2", 0, 1), t3 = Table.Group(t2, {l2{0}}, {{"list", each Table.ToList(Table.SelectColumns(Table.Sort(_, {{"2", 0}}), "1")), type list}}), t4 = Table.SplitColumn(Table.SplitColumn(f1(t0{1}), l2{0}, f2("-", 0), {"1", "3"}), "1", f2("/", 0), f4(1, 2)), t5 = Table.SplitColumn(Table.TransformColumns(t4, {"3", each f3(_)}), "3", f2("-", 1), f4(3, 2)), t6 = f9(f8(f7(Table.SplitColumn(t5, "4", f2("."), l1)), {{l1, "."}, {f4(1, 4), {"/", "-"}, l2{0}}}), l2{0}, "."), t7 = Table.RenameColumns(Table.NestedJoin(t6, l2{0}, t3, l2{0}, "list", 1), {{"list", l2{1}}}), t8 = Table.ExpandListColumn(Table.TransformColumns(t7, {l2{1}, each try _[list]{0} otherwise {}}), l2{1}) in t8
Повесил срез на таблицу Реестр (справа от таблицы), добавил UDF[vba]
Код
Public Function СрезВыбор(sName As String) As Variant Dim oSi As SlicerItem, i&, arr() As Variant On Error Resume Next Application.Volatile With ThisWorkbook.SlicerCaches(sName) For Each oSi In .SlicerItems If oSi.Selected Then ReDim Preserve arr(i) arr(i) = oSi.Value i = i + 1 End If Next End With СрезВыбор = arr() End Function
собственно, в этой формуле можно заменить ссылки на умные таблицы ссылками на диапазоны
Повесил срез на таблицу Реестр (справа от таблицы), добавил UDF[vba]
Код
Public Function СрезВыбор(sName As String) As Variant Dim oSi As SlicerItem, i&, arr() As Variant On Error Resume Next Application.Volatile With ThisWorkbook.SlicerCaches(sName) For Each oSi In .SlicerItems If oSi.Selected Then ReDim Preserve arr(i) arr(i) = oSi.Value i = i + 1 End If Next End With СрезВыбор = arr() End Function
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
...
