Страницы: 1
RSS
Как получить список имен диапазонов из диспетчера имен из закрытой книги с помощью vba
 
Помогите пожалуйста получить список имен диапазонов из диспетчера имен из закрытой книги с помощью vba с помощью vba. Есть файл, в котором в столбце А указаны пути к файлам с таблицами. В этих файлах возникают неправильные имена умных таблиц и из большого количества файлов необходимо найти те, где имена таблиц неправильные, чтобы зайти в них и исправить.
 
apfu, открыть книгу, пробежаться циклом по коллекции ActiveWorkbook.Names и запомнить в массив, закрыть книгу
Изменено: Jack Famous - 17.09.2021 14:42:51
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Jack Famous, Спасибо за оперативный ответ. Логику я понимаю, Вы правильно написали: открыть книгу, пробежаться циклом по коллекции ActiveWorkbook.Names и запомнить в массив, закрыть книгу, и в исходном файле вывести список имен с указанием их диапазонов.
Проблема заключается в том, что я не умею писать коды VBA. Я два дня искал подобный вопрос и его решение по форумам Excel, но ничего не нашел. Есть один вариант, но там выводится список из диспетчера имен того файла, гле находится сам макрос, а поменять на то, чтобы получать из другой закрытой книги у меня не получается.
 
Цитата
apfu: Я два дня искал подобный вопрос и его решение по форумам Excel, но ничего не нашел
Вывод списка имён (Names) книги Excel на новый лист
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Этот вариант я и нашел и у меня не получилось его переделать, чтобы получить список имен из диспетчера имен из закрытой книги. Если есть возможность. помогите пожалуйста.
Изменено: vikttur - 17.09.2021 16:47:28
 
apfu, из закрытой не получится. Нужно макросом открыть книгу, считать имена, закрыть книгу
 
Код
Option Explicit

Sub Main()
    Dim arr As Variant
    arr = ShowFileDialog()
    If UBound(arr) > 0 Then
        Dim wb As Workbook
        Application.EnableEvents = False
        Set wb = Workbooks.Open(arr(1), False, True)
        
        Dim brr As Variant
        brr = GetNamesArr(wb)
        wb.Close False
        
        Set wb = Workbooks.Add(1)
        With wb.Sheets(1).Cells(1, 1).Resize(UBound(brr, 1), UBound(brr, 2))
            .NumberFormat = "@"
            .Cells = brr
        End With
            
        Application.EnableEvents = True
    End If
End Sub

Function GetNamesArr(wb As Workbook) As Variant
    Dim arr As Variant
    ReDim arr(1 To 1, 1 To 1)
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim n As Name
    For Each n In wb.Names
        dic.Item(n.Name) = Array("Книга", n.Value)
    Next
    Dim sh As Worksheet
    For Each sh In wb.Sheets
    For Each n In sh.Names
        dic.Item(n.Name) = Array(sh.Name, n.Value)
    Next
    Next
    
    If dic.Count > 0 Then
        ReDim arr(1 To dic.Count, 1 To 3)
        Dim arK As Variant
        Dim arI As Variant
        arK = dic.Keys()
        arI = dic.Items()
        Dim y As Long
        For y = 1 To UBound(arr, 1)
            arr(y, 1) = arI(y - 1)(0)
            arr(y, 2) = arK(y - 1)
            arr(y, 3) = arI(y - 1)(1)
        Next
    End If
    GetNamesArr = arr
End Function

Function ShowFileDialog() As Variant
    Dim arr As Variant
    ReDim arr(0 To 0)
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Title = "Выбрать файлы отчетов" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Path 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then 'показывает диалог
        Else
            ReDim arr(1 To .SelectedItems.Count)
            'цикл по коллекции выбранных в диалоге файлов
            For lf = 1 To .SelectedItems.Count
                arr(lf) = .SelectedItems(lf) 'считываем полный путь к файлу
            Next
        End If
    End With
    ShowFileDialog = arr
End Function
 
Цитата
apfu написал:
В этих файлах возникают неправильные имена умных таблиц
а по любому это не имена в том виде который описан. Так что....
крутить еще два циклв по Worksheets.ListObjects.Name
Изменено: БМВ - 17.09.2021 16:21:49
По вопросам из тем форума, личку не читаю.
 
Цитата
apfu написал:
список имен диапазонов
и
Цитата
apfu написал:
имена умных таблиц
это разные вещи, хотя и то, и другое отображается в диспетчере задач.
Код
Sub qq()
    Dim sh As Worksheet, lb As ListObject
    For Each sh In ActiveWorkbook.Worksheets
        For Each lb In sh.ListObjects
            Debug.Print lb.Name
        Next
    Next
End Sub
 
МатросНаЗебре, Спасибо большое. но есть проблемы: выводятся только определенные имена, а имена таблиц нет. В столбце А - "Область". в в столбце В - "Имя" (но почему-то по "1_ФОТ'!Print_Area" и "2_командировки'!Print_Area" в имени "область печати" хотя по Print_Area понять можно, в столбце С - "Диапазон".
Можно ли чтобы выводились и имена таблиц с теми же параметрами?
Скриншоты приложил.
 
RAN, Спасибо, я таких тонкостей не знал. Попробовал Ваш код. но у меня ничего не получилось. Как его использовать или как-то изменить код МатросНаЗебре,
 
Цитата
apfu написал:
как-то изменить код  МатросНаЗебре
Я же не гадалка.
Вам лень правила прочитать, значит и ответ не шибко надобен.
Изменено: RAN - 17.09.2021 17:28:46
 
RAN, я действительно попробовал Ваш код: вставил в модуль, запустил, ничего не произошло, по этому и задал вопрос как использовать Ваш код.
Ответ мне шибко надобен, поэтому еще раз прочитал правила и не понял, чем оскорбил. Если уточните, то постараюсь исправить.
 
Цитата
apfu написал:
Если уточните, то постараюсь исправить
Уточняю.
Для того, чтобы тренироваться на кошках, нужно этих кошек иметь.
 
apfu, от вас нужен небольшой файл-пример (это написано в правилах, вы никого не оскорбляли)
 
Цитата
apfu написал:
вставил в модуль, запустил, ничего не произошло,
а если в редакторе VBE нажать сочетания клавиш Ctrl+G, а потом запустить? :)
По сути код не шибко сложный:
Код
Sub GetLO()
    Dim wb As Workbook, sh As Worksheet, lb As ListObject
    Dim sh_res As Worksheet
    Dim sf$, res(), lr&
    
    sf = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", 1, "Выбрать файл Excel", , False)
    If VarType(sf) = vbBoolean Then
        Exit Sub
    End If
    
    Application.ScreenUpdating = 0
    Set sh_res = ActiveWorkbook.Sheets.Add(ActiveWorkbook.Sheets(1))
    Set wb = Application.Workbooks.Open(sf)
    ReDim res(1 To 10000, 1 To 3)
    lr = 1
    res(lr, 1) = "Лист"
    res(lr, 2) = "Имя таблицы"
    res(lr, 3) = "Адрес таблицы"
    For Each sh In wb.Worksheets
        For Each lb In sh.ListObjects
            lr = lr + 1
            res(lr, 1) = sh.Name
            res(lr, 2) = lb.Name
            res(lr, 3) = lb.Range.Address(external:=True)
        Next
    Next
    sh_res.Cells(1, 1).Resize(lr, 3).Value = res
    wb.Close False
    Application.ScreenUpdating = 1
End Sub
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий(The_Prist) Щербаков, Спасибо огромное,
1. вставил в модуль от RAN, в редакторе, нажал сочетания клавиш Ctrl+G, а потом запустил, также ничего не произошло. Может я делаю что то не так.
2. Может быть для Вас это не шибко сложно, для меня это профессионально сделанный код. Еще раз огромное Спасибо, все прекрасно работает., это уже огромная помощь в решении моей задачи, но ...
3. У меня есть 3 папки в которых по 100 файлов-отчетов. Я захожу в каждый фай и проверяю в диспетчере имен наличие ошибок. Сделал книгу, где получаю адреса (полный путь) к файлам-отчетов из папок. Была задумка получать список имен умных таблиц (в т.ч. имен диапазонов) из диспетчера имен файлов-отчетов и в каком есть ошибки конкретно заходить и исправлять не перебирая все файлы.
Можно ли изменить Ваш код так, чтобы выбирая в ячейке последовательно адреса (полный путь) к файлам-отчетов из папок или выбирая в диалоговом окне все файлы-отчетов из папки, получать список имен умных таблиц (в т.ч. имен диапазонов) из диспетчера имен, и где ошибки, уже конкретно заходить и исправлять.
 
Цитата
apfu написал:
также ничего не произошло
потому что надо запускать когда активна книга с таблицами. Тогда в окне, отображенным по Ctrl+G, будет список.
Цитата
apfu написал:
Можно ли изменить Ваш код так
вообще лучше сразу писать задачу так, как хотите видеть её в итоге, раз в кодах не разбираетесь :) Подкорректировал
Код
Sub GetLO()
    Dim wb As Workbook, sh As Worksheet, lb As ListObject
    Dim sh_res As Worksheet
    Dim sf, af, res(), lr&
    
    af = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", 1, "Выбрать файлы Excel", , True)
    If VarType(af) = vbBoolean Then
        Exit Sub
    End If
    
    Application.ScreenUpdating = 0
    Set sh_res = ActiveWorkbook.Sheets.Add(ActiveWorkbook.Sheets(1))
    ReDim res(1 To 10000, 1 To 4)
    lr = 1
    res(lr, 1) = "Книга"
    res(lr, 2) = "Лист"
    res(lr, 3) = "Имя таблицы"
    res(lr, 4) = "Адрес таблицы"
    For Each sf In af
        Set wb = Application.Workbooks.Open(sf)
        For Each sh In wb.Worksheets
            For Each lb In sh.ListObjects
                lr = lr + 1
                res(lr, 1) = wb.Name
                res(lr, 2) = sh.Name
                res(lr, 3) = lb.Name
                res(lr, 4) = lb.Range.Address(external:=True)
            Next
        Next
        wb.Close False
    Next
    sh_res.Cells(1, 1).Resize(lr, 4).Value = res
    Application.ScreenUpdating = 1
End Sub
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий(The_Prist) Щербаков, Спасибо огромное, это супер.
Сразу не написал все, т.к. думал, что это сложно реализуемо, и хотел, хотя бы, минимальной помощи.
Еще раз Спасибо Вам огромное!
Страницы: 1
Наверх