| Цитата |
|---|
написал:
| Код |
|---|
[URL=#]?[/URL] 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 Dim fso As Object Sub Посчитать_в_ТТН() Set fso = CreateObject( "Scripting.FileSystemObject" ) Dim aFiles As Variant aFiles = ShowFileDialog() If IsEmpty(aFiles) Then Exit Sub Dim yReport As Long Dim aReport As Variant ReDim aReport(1 To UBound(aFiles), 1 To 3) Application.EnableEvents = False Application.ScreenUpdating = False Dim Application_Calculation As Long Application_Calculation = Application.Calculation Application.Calculation = xlCalculationManual Dim vFile As Variant For Each vFile In aFiles yReport = yReport + 1 JobFile vFile, aReport, yReport Next If yReport > 0 Then With Workbooks.Add(1).Sheets(1).Cells(1, 1).Resize(UBound(aReport, 1), UBound(aReport, 2)) .Value = aReport End With End If Application.Calculation = Application_Calculation Application.ScreenUpdating = True Application.EnableEvents = True End Sub Private Sub JobFile( ByVal sFull, aReport As Variant , yReport As Long ) Application.StatusBar = Right(sFull, 255) Dim wb As Workbook On Error Resume Next Workbooks(fso.GetFileName(sFull)).Close False On Error GoTo 0 Set wb = Workbooks.Open(sFull, False , True ) aReport(yReport, 1) = WorksheetFunction.CountA(wb.Sheets(1).Range( "A18:A25" )) aReport(yReport, 2) = wb.Name aReport(yReport, 3) = sFull wb.Close False Application.StatusBar = False End Sub Function ShowFileDialog() As Variant ' Dim rInitialFileName As Range ' Set rInitialFileName = ThisWorkbook.Names("шаблон").RefersToRange Dim oFD As FileDialog Dim x, lf As Long 'назначаем переменной ссылку на экземпляр диалога Set oFD = Application.FileDialog(msoFileDialogFilePicker) With oFD 'используем короткое обращение к объекту 'так же можно без oFD 'With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .Title = "Выбрать файлы" 'заголовок окна диалога .Filters.Clear 'очищаем установленные ранее типы файлов .Filters.Add "Excel files" , "*.xls*" , 1 'устанавливаем возможность выбора только файлов Excel '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы) .InitialFileName = ThisWorkbook.Path & "\" .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов) If .Show = 0 Then Exit Function 'показывает диалог Dim arr As Variant 'цикл по коллекции выбранных в диалоге файлов For lf = 1 To .SelectedItems.Count If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then If IsEmpty(arr) Then ReDim arr(1 To 1) ' rInitialFileName.Value = .SelectedItems(lf) Else ReDim Preserve arr(1 To UBound(arr) + 1) End If arr(UBound(arr)) = .SelectedItems(lf) 'считываем полный путь к файлу End If Next ShowFileDialog = arr End With End Function |
|
Ух-ты, Спасибо, а как пользоватся? Нужно скопировать написаный код создать и сохранить как макрос файл Эксель? Потом открыть сам макрос и можно выбрать в папке файлы которые будут подсчитывать количество заполненых ячеек? Или что-то путаю?
