Страницы: 1
RSS
Макрос сумы ячеек по разным файлам в папке
 
Здравствуйте.

Помогите пожалуйста подкорректировать макрос. Макрос рабочий, но нужны некоторые изменения. Я в этом вообще ноль.
Макрос суммирует ячейки (в даном случае F9) во всех файлах в папке, которая указывается после запуска макроса.

Что хочеться изменить:
1. Чтоб вместо ручного ввода адреса ячейки в макрос (F9), после запуска макрос суммировал ячейки на которой стоит курсор.
2. Чтоб каждый раз не выбирать папку, а прописать в макросе адрес папки.
Код
Sub Test()
Dim myPath As String, myName As String, Wb As Workbook, iSum As Single
 
    Application.ScreenUpdating = False
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Укажите рабочую папку"
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        myPath = .SelectedItems(1) & Application.PathSeparator
    End With
    myName = Dir(myPath & "*.xlsx")
    'цикл по всем файлам указанного типа
    Do While myName <> ""
        &#39;открываем очередной файл в режиме "Только для чтения" и присваиваем его переменной
        Set Wb = Workbooks.Open(Filename:=myPath & myName, ReadOnly:=True)
            
        &#39;делаем что надо
             iSum = iSum + Workbooks(Wb.name).Worksheets("Лист1").Range("F9").Value
 
        &#39;закрываем файл не сохраняя изменений в нём
        Wb.Close SaveChanges:=False
        &#39;определяем имя следующего файл в указаной директории
        myName = Dir
    Loop
 
     ActiveCell.Value = iSum
End Sub
Заранее благодарен за помощь
 
dima_dso, Здравствуйте!
Цитата
dima_dso написал:
1. Чтоб вместо ручного ввода адреса ячейки в макрос (F9), после запуска макрос суммировал ячейки на которой стоит курсор.
Предполагается, что нужно каждый раз указывать новую ячейку для суммирования?

Если так, то попробуйте такой вариант:
Код
Sub Test()
Dim myPath As String, myName As String, Wb As Workbook, iSum As Single, r

    myPath = "D:\Папка\"
    
    myName = Dir(myPath & "*.xlsx")
'   цикл по всем файлам указанного типа
    Do While myName <> ""
'        открываем очередной файл в режиме "Только для чтения" и присваиваем его переменной
        Set Wb = Workbooks.Open(Filename:=myPath & myName, ReadOnly:=True)
        Wb.Activate
        
'        делаем что надо
        On Error Resume Next
        Set r = Application.InputBox("Выберите ячейку для сумирования:", Type:=8)
        
        If r Is Nothing Then
            Wb.Close SaveChanges:=False
            Exit Sub
        End If
        On Error GoTo 0
        
        iSum = iSum + WorksheetFunction.Sum(r)
        
'        закрываем файл не сохраняя изменений в нём
        Wb.Close SaveChanges:=False
'        определяем имя следующего файл в указаной директории
        myName = Dir
        
    Loop
    
    ActiveCell.Value = iSum
    
End Sub
Наша суть отражается в наших повторяющихся действиях. Отсюда следует, что совершенство есть не действие, а привычка. Аристотель.
 
Цитата
dima_dso написал:
2. Чтоб каждый раз не выбирать папку, а прописать в макросе адрес папки.
Вот тут то в чем проблема? это же проще чем написать блок
Код
With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Укажите рабочую папку"
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        myPath = .SelectedItems(1) & Application.PathSeparator
    End With

просто переменной присваиваете полный путь к папке
Код
 myPath = "Путь к файлам"
"Все гениальное просто, а все простое гениально!!!"
 
как вариант

Код
Sub main()
    Dim ipath$, fname$, isum&, addr$
    Application.ScreenUpdating = False
    ipath = "Путь к файлам"
    addr = ActiveCell.Address
    fname = Dir(ipath)
    Do While fname <> ""
        If fname <> ThisWorkbook.Name Then
            With GetObject(ipath & fname).Worksheets(1)
                isum = isum + .Range(addr).Value
                .Parent.Close False
            End With
        End If
        fname = Dir
    Loop
    Application.ScreenUpdating = True
    msgbox isum
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
Valo, Указал в макросе адрес папки с файлами, запускаю макрос, но у почему-то сразу в ячейку возвращает ноль и больше ничего не происходит...  :(  Может я что-то не так делаю? А то я в макросах вообще дуб, только скопировать и запустить знаю.
 
Папка существует?
 
Nordheim, "как вариант"
Указал в макросе адрес папки с файлами, запускаю макрос, но на экране появляется окно в котором в  высвечивает ноль. И всё...  :(
Может я что-то не так делаю? А то я в макросах вообще дуб, только скопировать и запустить знаю.
Изменено: dima_dso - 06.04.2020 16:47:35
 
а так?
Код
Sub main()
    Dim ipath$, fname$, isum&, addr$
    Application.ScreenUpdating = False
    ipath = "Путь к файлам"
    addr = ActiveCell.Address
    fname = Dir(ipath & "*.xls*")
    Do While fname <> ""
        If fname <> ThisWorkbook.Name Then
            With GetObject(ipath & fname).Worksheets(1)
                isum = isum + .Range(addr).Value
                .Parent.Close False
            End With
        End If
        fname = Dir
    Loop
    Application.ScreenUpdating = True
    msgbox isum
End Sub


Если 0 то может ячейки не заполнены в файлах на 1 листе?
Изменено: Nordheim - 06.04.2020 17:37:53
"Все гениальное просто, а все простое гениально!!!"
 
Всем спасибо за помощь!
Всё получилось. Долго мучился пока не понял, что когда указываю путь к файлам, обязательно надо в конце ставить " \ ". Без этого не работает.
То есть например:
Не так "D:\1"
А вот так "D:\1\"
Изменено: dima_dso - 01.06.2020 12:43:33 (Опечатка)
Страницы: 1
Наверх