Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Подсчёт количества заполненых ячеек в определённом диапазоне в тысяче файлов Excel
 
#1
01.12.2022 00:06:28
Добрый вечер.  Может кто подскажет, как можно подсчитать количество заполненных ячеек в определенном диапазоне например А1:А11, но в тысяче файлов Excel. Нужна только общая цифра.  Может есть какой макрос?? Заранее спасибо  
Изменено: Optimus_Prime - 01.12.2022 00:07:35
 
 
 
#2
01.12.2022 01:10:41
а потом окажется, что нужно было считать заполненные только на листе "Отчёт", а не на всех листах
 
 
 
#3
01.12.2022 01:24:26
и где найти хоть один из этой тысячи файлов
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#4
01.12.2022 09:43:14
Доброе утро). Есть ттн-ка в формате Эксель, их много, строки на продукцию не добавляются и не уменьшаются, фиксировано 8 строк (с 18 по 25 строку). Но могут быть заполнены одна, две строки или все восемь. Нужно просчитать общее количество позиций во всех таких файлах в папке (их в папке много). В одном файле только один лист. Спасибо.
 
 
 
#5
01.12.2022 10:28:03
вариант
 
 
 
#6
01.12.2022 10:54:54
Эти ТТН-ки заполняють разные люди, в разных местах, сохраняются на сервере в папках по дням. Никто не будет соблюдать очередность заполнения  потому что заказов очень много и естетвенно ттн-ок. 1,2,3 не будет первая ячейка это уникальный код выпускаемой продукции. За ответ спасибо.
 
 
 
#7
01.12.2022 11:08:52
Код
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
 
 
 
#8
01.12.2022 11:31:07
Цитата
написал:
Код
    [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  
 
Ух-ты, Спасибо, а как пользоватся? Нужно скопировать написаный код создать и сохранить как макрос файл Эксель? Потом открыть сам макрос и можно выбрать в папке файлы которые будут подсчитывать количество заполненых ячеек? Или что-то путаю?
 
 
 
#9
01.12.2022 11:52:24
Optimus_Prime,
вместо того, чтобы обьяснить свою задачу, вы теперь хотите чтобы МатросНаЗебре, описал свой макрос)
у вас написана кое-какая задача, предложенный макрос кое-что делает - вроде все сходится))

заставить пользователя выбрать тысячи файлов в разных папках - это получить тысячу проклятий на голову написвшего такое решение
я уже спрашивал у вас где искать ваши файлы? вы не видите или делаете вид что не видите вопроса или еще хуже не понимаете, что без этой информации задача не решается((
Изменено: Ігор Гончаренко - 01.12.2022 12:02:27
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#10
01.12.2022 12:15:40
Ігор Гончаренко,
ну вначале может и не полная инфа была о задаче, но сегодня утром был добавлен файл и к этому файлу вроде бы полное понятное описание что хотелось бы видеть.
Отдельно спасибо за ответ te1n и МатросНаЗебре. Но есть вопрос и я его задал, потому-что не все мне понятно, а Вашего сарказма Ігор Гончаренко пока не понимаю, это Вы так пытаетесь помочь?  
 
 
 
#11
01.12.2022 12:31:28
Так, еще раз. Есть папка на сервере например 01.12.2022 в ней файлы Эксель (их много) - это ТТН-ки.  Есть строки для заполнения на продукцию, они не добавляются и не уменьшаются, фиксировано 8 строк (с 18 по 25 строку). Но могут быть заполнены одна, две строки или все восемь. Нужно просчитать общее количество позиций во всех таких файлах в папке (их в папке много). В одном файле только один лист. Эти ТТН-ки заполняють разные люди, в разных местах, сохраняются на сервере в папках по дням. Никто не будет соблюдать очередность заполнения,  потому что заказов очень много и естетвенно ттн-ок. 1,2,3 не будет первая ячейка это уникальный код выпускаемой продукции.
Что нужно и возможно ли: Просчитать количество заполненных ячеек в диапазоне A18:A25 всех имеющихся ТТН  в этой папке (01.12.2022), или за 30.11.2022 или другую дату.
Файл прикреплен выше.
 
 
 
#12
01.12.2022 15:11:04
открывайте файл, пишите в В2 название папки
Код
Function CalcKvo(ByVal fd)
  Dim pt$, fn$, ps$
  If fd = "" Then CalcKvo = "Не указано название папки!": Exit Function
  ps = Application.PathSeparator
  If InStr(fd, ":") = 0 Then
    fd = ThisWorkbook.Path & ps & fd
  End If
  If Dir(fd, vbDirectory) = "" Then _
    CalcKvo = "Папка " & fd & " не существует!": Exit Function
  fn = Dir(fd & ps & "*.xls*")
  Do While fn <> ""
    CalcKvo = CalcKvo + InFile(fd & ps & fn)
    fn = Dir
  Loop
End Function

Function InFile&(fn)
  Dim wb As Workbook
  Set wb = Workbooks.Open(fn)
  InFile = WorksheetFunction.CountA(wb.Worksheets(1).Range("A18:A25"))
  wb.Close False
End Function
Изменено: Ігор Гончаренко - 01.12.2022 15:43:46
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#13
01.12.2022 22:48:38
Optimus_Prime, это не важно, попробуйте ради интереса в ТТН не цифры проставлять, а уникальные ключи
 
 
 
Страницы: 1
Наверх