Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос. Выбор файлов в каталоге.
 
#1
25.10.2017 14:05:02
Всем доброго времени суток.
В коде выбирается каталог и файлов не видно, что оказалось не удобно, что необходимо изменить в коде, чтобы пользователю нужно было выделять файлы при открытии каталога.

Код
Sub Микро_на_сдачу()
 
    Dim sFolder As String, sFiles As String
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"        
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'отключаем обновление экрана, чтобы наши действия не мелькали
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*№*.xlsm")
    Do While sFiles <> ""
        'открываем книгу
        Workbooks.Open sFolder & sFiles
        'действия с файлом
    'Заполняем формулы
    Worksheets("Микроучасток").Range("B2").Value = "ДАТА ОТЧЕТА"
    Worksheets("Микроучасток").Range("B3").Value = ThisWorkbook.Sheets(1).Range("K3")  'СОБСТВЕННО САМА ДАТА ОТЧЕТА
    Worksheets("Микроучасток").Range("B3").NumberFormat = "m/d/yyyy"
    'Закончили с формулами
 
        'Закрываем книгу с сохранением изменений
        ActiveWorkbook.Close True 'если поставить False - книга будет закрыта без сохранения
        sFiles = Dir
    Loop
    'возвращаем ранее отключенное обновление экрана
    Application.ScreenUpdating = True
     
End Sub
 
 
 
#2
25.10.2017 14:16:46
Первых два примера. На выбор
Согласие есть продукт при полном непротивлении сторон
 
 
 
#3
25.10.2017 14:20:21
Используйте Application.FileDialog(msoFileDialogFilePicker)
 
 
 
#4
25.10.2017 14:54:23
Спасибо всем.
Цитата
Hugo написал:
Используйте Application.FileDialog(msoFileDialogFilePicker)
Ага я тоже так подумал, вставлю в код msoFileDialogFilePicker заместо msoFileDialogFolderPicker, и дело в шляпе, хрен там.
Так как в VBA не силен, то трудно даже с простыми вещами.
Свой код переделать так как надо не смог.
Сделал по новому. вот так.
На тестовом файле работает, попробую на рабочие перенести.
Код
Sub ShowFileDialog()
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .InitialFileName = ThisWorkbook.Path & "\" 'путь "по умолчанию" расположение файла.
        If .Show = 0 Then Exit Sub 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            x = .SelectedItems(lf) 'считываем полный путь к файлу
            'отключаем обновление экрана, чтобы наши действия не мелькали
            Application.ScreenUpdating = False
            Workbooks.Open x 'открытие книги
            'можно также без х
            'Workbooks.Open .SelectedItems(lf)
    'Копирование даты отчета и выравнивание строк
    Sheets("Микроучасток").Select
    Rows("1:1").RowHeight = 20
    Rows("2:2").RowHeight = 20
    Rows("3:3").RowHeight = 20
    Rows("4:4").RowHeight = 20
    'конец выравнивания строк
    'Закрываем книгу с сохранением изменений
        ActiveWorkbook.Close True 'если поставить False - книга будет закрыта без сохранения
        Next
    End With
End Sub
Изменено: Николай - 25.10.2017 14:57:11
 
 
 
#5
25.10.2017 15:22:13
Это    
Код
    Sheets("Микроучасток").Select
    Rows("1:1").RowHeight = 20
    Rows("2:2").RowHeight = 20
    Rows("3:3").RowHeight = 20
    Rows("4:4").RowHeight = 20
то же , что и это    
Код
Sheets("Микроучасток").Rows("1:4").RowHeight = 20
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#6
25.10.2017 15:32:28
Можно попробовать так
Код
Sub www()
Dim arr()
arr = Application.GetOpenFilename("(*.xls*),*.xls*", , , , True)
End Sub
А потом обращаться к каждому элементу массива.
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#7
25.10.2017 15:32:38
Не работает.
Код
Sub Подготовка_к_отчету()
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .InitialFileName = ThisWorkbook.Path & "\" 'путь "по умолчанию" расположение файла.
        If .Show = 0 Then Exit Sub 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            x = .SelectedItems(lf) 'считываем полный путь к файлу
       With UserForm1
        .Show 0
        .Label1.Caption = "Работаем..."
        .Repaint
        For i = 1 To 100000000
        Next

        'отключаем обновление экрана, чтобы наши действия не мелькали
        Application.ScreenUpdating = False
        Workbooks.Open x 'открытие книги
        'можно также без х
        'Workbooks.Open .SelectedItems(lf)        
        'действия с файлом
        
    'Выравнивание строк
    Sheets("Микроучасток").Select
    Rows("1:1").RowHeight = 20
    Rows("2:2").RowHeight = 20
    Rows("3:3").RowHeight = 20
    Rows("4:4").RowHeight = 20
    'конец выравнивания строк
    
        'Закрываем книгу с сохранением изменений
        ActiveWorkbook.Close True 'если поставить False - книга будет закрыта без сохранения
        Next
    Loop
    'возвращаем ранее отключенное обновление экрана
    Application.ScreenUpdating = True
    .Label1.Caption = "ГОТОВО"
    End With
End Sub


Пишет Next without for
Ни как не могу понять как указать правильно этот Next
В прошлом макросе было sFiles = Dir
А тут как надо? Подскажите пожалуйста.
Изменено: Николай - 25.10.2017 15:33:14
 
 
 
#8
25.10.2017 15:39:34
Ошибку можно обыграть так.
Код
Sub www()
Dim arr()
On Error Resume Next
arr = Application.GetOpenFilename("(*.xls*),*.xls*", , , , True)
If Err <> 0 Then Err.Clear: Exit Sub
Range("a1").Value = "Test"
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#9
25.10.2017 15:40:11
Что за Loop?
 
 
 
#10
25.10.2017 15:44:12
В коде сообщения №7 2 раза открывается ссылка With:
Код
With Application.FileDialog(msoFileDialogFilePicker)
Код
With UserForm1
И всего 1 раз End With поэтому и ругается.
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#11
25.10.2017 15:51:53
Может это подойдет?
Код
Sub test()
Dim arr(), i&, book As Workbook
Application.ScreenUpdating = False
On Error Resume Next
arr = Application.GetOpenFilename("(*.xls*),*.xls*", , , , True)
If Err <> 0 Then Err.Clear: Exit Sub
For i = 1 To UBound(arr)
    Set book = Workbooks.Open(Filename:=arr(i))
    With book
        .Sheets("Микроучасток").Rows("1:4").RowHeight = 20
        .Close True
    End With
Next i
Application.ScreenUpdating = True
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#12
25.10.2017 17:30:10
Цитата
Hugo написал:
Что за Loop?
Понятия не имею.
вот что нашел в инете.
Loop - ключевое слово, указывает на окончание тела цикла и обозначает место, из которого VBA возвращается в начало цикла для проверки условия
 
 
 
#13
25.10.2017 17:33:11
Вот как выглядит оригинальный рабочий файл.
Если кому конечно будет интересно.
 
 
 
#14
25.10.2017 17:36:07
Цитата
Николай написал:
указывает на окончание тела цикла
- вот где ключевое слово :)
Что-то я в коде не наблюдаю начало этого цикла.
 
 
 
#15
25.10.2017 17:54:52
Hugo,
Этот loop вот из этого показа картинки с надписью работаем :-)
Код
With UserForm1
        .Show 0
        .Label1.Caption = "Работаем..."
        .Repaint
        For i = 1 To 100000000
        Next

З.Ы. Надо будет и в коде смайлик прописать :-)
 
 
 
#16
25.10.2017 17:57:10
Вопрос про Loop снимаю, нашёл наконец где Do :) ....
Но только в первом варианте кода.
В #7 25 Окт 2017 15:32:38 оно лишнее.
Изменено: Hugo - 26.10.2017 16:30:09
 
 
 
#17
25.10.2017 19:51:46
Вот такой код отрабатывает корректно.
Код
Sub Подготовка_к_отчету()
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .InitialFileName = ThisWorkbook.Path & "\" 'путь "по умолчанию" расположение файла.
        If .Show = 0 Then Exit Sub 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            x = .SelectedItems(lf) 'считываем полный путь к файлу
        'отключаем обновление экрана, чтобы наши действия не мелькали
        Application.ScreenUpdating = False
        Workbooks.Open x 'открытие книги
        'можно также без х
        'Workbooks.Open .SelectedItems(lf)
        'действия с файлом
        
    'Выравнивание строк
    Sheets("Микроучасток").Rows("1:4").RowHeight = 20
    'конец выравнивания строк
    
        'Закрываем книгу с сохранением изменений
        ActiveWorkbook.Close True 'если поставить False - книга будет закрыта без сохранения
        Next
    
    'возвращаем ранее отключенное обновление экрана
    Application.ScreenUpdating = True
    
    End With
End Sub


Проблема возникает при добавлении  

Кода картинки о выполнении.
Код
With UserForm1
        .Show 0
        .Label1.Caption = "Работаем..."
        .Repaint
        For i = 1 To 100000000
        Next
...
...
...

.Label1.Caption = "ГОТОВО"

Как-то не правильно значит добавляю, кто сможет подсказать как правильно сделать?
 
 
 
#18
26.10.2017 11:27:57
Победил методом проб и ошибок.
Вот такой код заработал на ура.
Код
Sub Подготовка_к_отчету()
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .InitialFileName = ThisWorkbook.Path & "\" 'путь "по умолчанию" расположение файла.
        If .Show = 0 Then Exit Sub 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            x = .SelectedItems(lf) 'считываем полный путь к файлу
        'отключаем обновление экрана, чтобы наши действия не мелькали
        Application.ScreenUpdating = False
        With UserForm1
        .Show 0
        .Label1.Caption = "Работаем..."
        .Repaint
        For i = 1 To 100000000
        Next
        .Label1.Caption = "ГОТОВО"
        End With
        Workbooks.Open x 'открытие книги
        'можно также без х
        'Workbooks.Open .SelectedItems(lf)
        'действия с файлом
        
    'Выравнивание строк
    Sheets("Микроучасток").Rows("1:4").RowHeight = 20
    'конец выравнивания строк

    
    'Закрываем книгу с сохранением изменений
        ActiveWorkbook.Close True 'если поставить False - книга будет закрыта без сохранения
        Next
    
    'возвращаем ранее отключенное обновление экрана
    Application.ScreenUpdating = True
     
     End With
End Sub
 
 
 
#19
26.10.2017 11:47:20
Это зачем в коде?
Код
For i = 1 To 100000000
Next
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#20
26.10.2017 16:21:37
Nordheim,
Понятия не имею, я предполагал что это ограничитель максимального количества циклов, так как файлов у меня всего 18 то и не особо и заморачивался.
З.Ы. Так как желание научится VBA есть, а учителей нет, то стараюсь тянуть готовый код из примеров, или аналогичных задач (что находятся поиском) подстраивать под свои нужны, и если уже совсем никак, то иду на форумы за помощью.
В начале VBA код вообще казался мне китайской грамотой, но постепенно понимаю что к чему, но знаний все равно мало.
 
 
 
Страницы: 1
Читают тему
Наверх