Добрый вечер! Есть функция открывающая диалоговое окно, При открытии показываются имена листов всех открытых книг и листы книги, которую нужно открыть, причем в диалоге уже стоит выбор на каком -то листе. Как не показывать листы всех открытых книг, а только выбранной и как сделать так чтобы в диалоговом окне не был выделен какой-либо из листов?
Код
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
Может у нас терминология разная, но...В сообщении приведен исключительно код выбора файлов, никакие листы там не показываются. Уверены, что все нам показали? Да и непонятно, о каком выборе речь и как выбираете - если надо выбрать только одну книгу - зачем тогда цикл 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, текста которой у нас опять же нет). В приведенном коде Вы используете только одну книгу и активный лист. В общем, скорее всего проблема в непонимании что у Вас где делается...
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
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
Вот в этом диалоге не получится показывать только один лист. Тут лучше свою форму сделать, которая будет выводить листы только выбранной книги в ListBox и все. И обрабатывать этот выбор будет потом проще и лишнее все можно с глаз убрать.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...