Страницы: 1
RSS
Отобразить в диалоговом окне только листы выбранной книги
 
Добрый вечер!
Есть функция открывающая диалоговое окно, При открытии показываются имена листов всех открытых книг и листы книги, которую нужно открыть, причем в диалоге уже стоит выбор на каком -то листе.
Как не показывать листы всех открытых книг, а только выбранной и как сделать так чтобы в диалоговом окне не был выделен какой-либо из листов?
Код
Function ShowFileDialog() As Workbook
    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.Name 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewList 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To 1 '.SelectedItems.Count
            x = .SelectedItems(lf) 'считываем полный путь к файлу
            Set ShowFileDialog = Workbooks.Open(x) 'открытие книги
            'можно также без х
            'Workbooks.Open .SelectedItems(lf)
        Next
    End With
End Function
Изменено: Тимофеев - 20.06.2022 20:57:17
 
Может у нас терминология разная, но...В сообщении приведен исключительно код выбора файлов, никакие листы там не показываются. Уверены, что все нам показали? Да и непонятно, о каком выборе речь и как выбираете - если надо выбрать только одну книгу - зачем тогда цикл For lf = 1 To 1? Можно просто
Код
x = .SelectedItems(1)
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
да я наверное путаю, тогда наверное в этом Application.Dialogs(xlDialogWorkgroup).Show ActiveSheet.Name
Код
Sub ReorganizeWithDialog()
    Dim wb As Workbook
    Set wb = ShowFileDialog()
    If Not wb Is Nothing Then
        Application.Dialogs(xlDialogWorkgroup).Show ActiveSheet.Name
        Reorganize wb
        wb.Close False
    End If
End Sub
 
Цитата
Тимофеев написал:
Как не показывать листы всех открытых книг
ну вот этого здесь тоже нет(если конечно, это не в функции Reorganize, текста которой у нас опять же нет). В приведенном коде Вы используете только одну книгу и активный лист. В общем, скорее всего проблема в непонимании что у Вас где делается...
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
все что есть, больше нет ничего
Дмитрий, тут еще вопрос по применении Вашей функции с Вашего сайта Как получить расшифровку значений в формулах в соседней ячейке (planetaexcel.ru)
Код
Option Explicit
Sub ReorganizeWithDialog()
    Dim wb As Workbook
    Set wb = ShowFileDialog()
    If Not wb Is Nothing Then
        Application.Dialogs(xlDialogWorkgroup).Show ActiveSheet.Name
        Reorganize wb
        wb.Close False
    End If
End Sub
Function ShowFileDialog() As Workbook
    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.Name 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewList 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To 1 '.SelectedItems.Count
            x = .SelectedItems(lf) 'считываем полный путь к файлу
            Set ShowFileDialog = Workbooks.Open(x) 'открытие книги
            'можно также без х
            'Workbooks.Open .SelectedItems(lf)
        Next
    End With
End Function
Sub Reorganize(wb As Workbook)
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = ActiveSheet
    Dim arr As Variant
    arr = GetArr(sh1)
    Set sh2 = GetSh2(sh1)
    Dim frr As Variant
    frr = GetNoEmptyRowArr(arr, sh1, sh2)
    If Not IsEmpty(frr) Then
        OutArr frr, sh2
        SaveWb sh2.Parent, wb
    End If
End Sub
Sub SaveWb(wb2 As Workbook, wb1 As Workbook)
    Dim newName As String
    newName = GetNewName(wb1.Name)
    newName = wb1.Path & "\" & newName
    On Error Resume Next
    Kill newName
    On Error GoTo 0
    wb2.SaveAs Filename:=newName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    'wb2.Close
End Sub
Function GetNewName(ByVal oldName As String) As String
    oldName = Replace(oldName, ".xlsb", ".xlsx")
    oldName = Replace(oldName, ".xlsm", ".xlsx")
    oldName = Replace(oldName, ")", "(")
    Dim arr As Variant
    arr = Split(oldName, "(")
    Dim newName As String
    If UBound(arr) > 0 Then
        If IsNumeric(arr(UBound(arr))) Then
            arr(UBound(arr)) = arr(UBound(arr)) + 1
            arr(UBound(arr)) = "(" & arr(UBound(arr)) & ")"
            newName = Join(arr, "")
        End If
    End If
    If newName = "" Then
        With CreateObject("Scripting.FileSystemObject")
            newName = .GetBaseName(oldName) & " (Объемы).xlsx"
        End With
    End If
    GetNewName = newName
End Function
Function GetSh2(sh1 As Worksheet) As Worksheet
    Dim sh2 As Worksheet
    sh1.Copy
    Set sh2 = ActiveSheet
    sh2.Cells.Clear
    With sh2.PageSetup
        .Orientation = xlPortrait
        .LeftMargin = Application.InchesToPoints(1.96850393700787)
        .RightMargin = Application.InchesToPoints(1.96850393700787)
        .TopMargin = Application.InchesToPoints(1.96850393700787)
        .BottomMargin = Application.InchesToPoints(3.93700787401575)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
    End With
    Set GetSh2 = sh2
End Function
Sub OutArr(arr As Variant, sh2 As Worksheet)
    'With Workbooks.Add(1)
    With sh2.Parent
        With .Sheets(1)
            With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Cells = arr
            End With
        End With
        .Saved = True
    End With
End Sub
Function GetNoEmptyRowArr(arr As Variant, sh1 As Worksheet, sh2 As Worksheet) As Variant
    Dim y As Long
    Dim n As Long
    For y = 28 To UBound(arr, 1)
        n = n + 1 + IsEmpty(arr(y, 1))
    Next
    If n > 0 Then
        Dim brr As Variant
        ReDim brr(1 To n, 1 To UBound(arr, 2))
        Dim x As Integer
        Dim yOZ As Long
        n = 0
        For y = 28 To UBound(arr, 1)
            If Not IsEmpty(arr(y, 1)) And Not IsEmpty(arr(y, 2)) Then
                n = n + 1
                For x = 1 To UBound(arr, 2)
                    brr(n, x) = arr(y, x)

                Next
                If yOZ = 0 Then
                    yOZ = n
                    'brr(yOZ, 11) = 0
                End If
                If IsNumeric(brr(yOZ, 11)) Then
                    If IsNumeric(arr(y, 11)) Then
                        brr(yOZ, 11) = brr(yOZ, 11) - arr(y, 11)
                    End If
                End If
                sh1.Rows(y).Copy sh2.Cells(n, 1)
            End If
            If arr(y, 3) = "Всего по позиции:" Then
                If IsNumeric(brr(yOZ, 11)) Then
                    If IsNumeric(arr(y, 10)) Then
                        brr(yOZ, 11) = brr(yOZ, 11) + arr(y, 10)
                    End If
                End If
                yOZ = 0
            End If
        Next
        GetNoEmptyRowArr = brr
    End If
End Function
  
Function GetArr(sh As Worksheet) As Variant
    With sh
        GetArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 3).End(xlUp).Cells(1, 11 - 2))
    End With
End Function
Изменено: Тимофеев - 21.06.2022 15:07:25
 
Вот в этом диалоге не получится показывать только один лист.
Тут лучше свою форму сделать, которая будет выводить листы только выбранной книги в ListBox и все. И обрабатывать этот выбор будет потом проще и лишнее все можно с глаз убрать.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Страницы: 1
Наверх