Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос выбирающий и открывающий файл по заданному параметру, выбор файла по названию, согласно заданного параметра
 
#1
04.08.2016 00:01:20
Идея автоматизации процесса создания нового отчёта из уже имеющихся отчётов.
Скажем в директории С/Отчёты лежит много отчётов с такими именами:
Отчёт по 2016.01.20.xlsx
Отчёт по 2016.01.27.xlsx
Отчёт по 2016.01.31.xlsx
Отчёт по 2016.02.09.xlsx
Отчёт по 2016.02.17.xlsx
Отчёт по 2016.02.26.xlsx
Отчёт по 2016.03.05.xlsx
Данные в этих отчётах представлены нарастающим итогом, начиная с 01.01.2016 по дату, указанную в названии файла.
Задача в новом файле, например, "Отчёт за февраль 2016.xlsx" автоматически создать отчёт за февраль. Выбор месяца задаётся в ячейке "С4" (данного файла).
Очевидно, что для построения отчёта сначала надо открыть файл "Отчёт по 2016.01.31.xlsx"(1), взять оттуда данные, потом открыть файл "Отчёт по 2016.02.26.xlsx"(2) и взять оттуда данные.
Собственно нужно 2 строчки кода, выбирающие и открывающие именно те файлы, которые соответствуют критерию, заданному в ячейке "С4", т.е. месяцу.
Это решаемо?
 
 
 
#2
04.08.2016 04:49:47
Пусть месяц в ячейке "C4" задан цифрой. Тогда перебрать все файлы указанного месяца можно так:
Код
Sub Main()
    Dim p As String, f As String, wb As Workbook, mes As String
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    mes = Format([C4], "00")
    p = "C:\Отчеты\": f = Dir(p & "Отчет по 2016." & mes & ".??.xlsx")
    Do While f <> ""
        Set wb = Workbooks.Open(p & f)
        '...
        'Действия с каждым файлом указанного месяца
        '...
        wb.Close False
        f = Dir
    Loop
End Sub
Если в ячейке "C4" находится название месяца (например, "февраль"), то переменную mes в коде макроса нужно определять так:
Код
mes = Format(Month(DateValue("1 " & [C4] & " 2000")), "00")
Изменено: SAS888 - 04.08.2016 04:55:57 (Добавлено)
Чем шире угол зрения, тем он тупее.
 
 
 
#3
04.08.2016 06:59:48
Если же Вам нужны ТОЛЬКО "крайние" файлы, то определить их можно так:
Код
Sub Main()
    Dim p As String, f As String, f1 As String, f2 As String, mes1 As Integer, mes2 As Integer
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    mes2 = [C4]: mes1 = mes2 - 1
    p = "C:\Отчеты\": f = Dir(p & "Отчет по " & "????.??.??.xlsx")
    Do While f <> ""
        Select Case Split(f, ".")(1)
            Case Format(mes1, "00"): f1 = IIf(f1 > f, f1, f)
            Case Format(mes2, "00"): f2 = IIf(f2 > f, f2, f)
        End Select
        f = Dir
    Loop
    'Переменная f1 содержит имя последнего файла за предыдущий месяц
    'Переменная f2 содержит имя последнего файла за текущий месяц
    MsgBox f1 & ":" & f2
End Sub
ПРИМЕЧАНИЯ:
1. Месяц в ячейке "C4" указан цифрой.
2. Значение в ячейке "C4" должно быть от 2 до 12. Т. е. в пределах одного года. Если требуется отлавливать переход через год, то макрос будет чуть сложнее.
Изменено: SAS888 - 04.08.2016 07:08:29 (Добавлено)
Чем шире угол зрения, тем он тупее.
 
 
 
#4
04.08.2016 19:51:43
Спасибо! Получилось наполовину  :)
Файл со старшей датой текущего месяца обрабатывается, а вот прикрутить файл со старшей датой предыдущего месяца не получилось.
Приведу полный код макроса, только вместо автоматического выбора второго файла - ручной выбор. Собственно прошу подсказать, код для автоматизации по второму файлу.
Код
Sub Отчёт_за_месяц()
'
' Отчёт_за_месяц Макрос
'

'
        Dim p As String, f As String, wb As Workbook, mes As String
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    mes = Format([C4], "00")
    p = "C:\Отчеты\": f = Dir(p & "Отчет по 2016." & mes & ".??.xlsx")
    Do While f <> ""
        Set wb = Workbooks.Open(p & f)
    Range("D6:F114").Select
    Selection.Copy
    Windows("Отчет за месяц.2.0.xlsm").Activate
    Range("G6:I114").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Workbooks.Open Filename:= _
        "C:\Отчеты\Отчет по 2016.01.29.xlsx"
    ActiveWindow.SmallScroll Down:=-90
    Range("D6:F114").Select
    Selection.Copy
    Windows("Отчет за месяц.xlsm").Activate
    Range("D6:F114").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Windows("Отчет по 2016.01.29.xlsx").Activate
    ActiveWindow.Close
wb.Close False
        f = Dir
    Loop
End Sub
т.е. надо поменять строки
Код
Workbooks.Open Filename:= _
        "C:\Отчеты\Отчет по 2016.01.29.xlsx"
и строку
Код
Windows("Отчет по 2016.01.29.xlsx").Activate
может последняя и вообще не нужна, не уверен.
 
 
 
#5
05.08.2016 03:22:37
Думаю, разберётесь что к чему...

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
 
 
#6
05.08.2016 08:33:13
Спасибо, но туго до меня доходит :)
Мне бы кусок кода, который надо подставить вместо строк 19 и 20 в приведенном мной коде макроса.
 
 
 
#7
05.08.2016 08:50:17
presentt, что именно не понятно? Приведен алгоритм нахождения последнего и последнего в предыдущем месяце файла отчёта. Вы попробуйте разобраться (что не понятно - спрашивайте), а преподнести готовенькое на блюдечке с голубой каёмочкой - медвежья услуга, которую оказываю в случае, если мне интересно решение ради тренировки, либо из меркантильных соображений.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
 
 
#8
06.08.2016 00:57:32
Настроил, всё работает, вот только появилась досадная мелочь, не получается закрыть открываемые файлы, помеченные, как f1 и f2. Собственно, вот код макроса:
Код
Sub Main()
    Dim p As String, f As String, f1 As String, f2 As String, mes1 As Integer, mes2 As Integer
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    mes2 = [C4]: mes1 = mes2 - 1
    p = "C:\Отчеты\": f = Dir(p & "Отчет по " & "????.??.??.xlsx")
    Do While f <> ""
        Select Case Split(f, ".")(1)
            Case Format(mes1, "00"): f1 = IIf(f1 > f, f1, f)
            Case Format(mes2, "00"): f2 = IIf(f2 > f, f2, f)
        End Select
        f = Dir
        Loop
   Workbooks.Open (p & f1)
   Range("D6:F114").Select
    Selection.Copy
    Windows("Отчет за месяц.xlsm").Activate
    Range("D6:F114").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Workbooks.Open (p & f2)
   Range("D6:F114").Select
    Selection.Copy
    Windows("Отчет за месяц.xlsm").Activate
    Range("G6:I114").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        End Sub
Подскажите, как сделать Close, а то как-то незаконченно получилось.
 
 
 
#9
06.08.2016 12:43:01
Код
Workbooks.Open (p & f1)
set wbf1 = activeworkbook
...
Workbooks.Open (p & f2)
set wbf2 = activeworkbook
...
wbf1.close ' false
wbf2.close ' false
Если открытые книги перед закрытием надо сохранить то пишите после ".close"  true, иначе - false.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
 
 
#10
07.08.2016 17:01:26
Код
Sub Main()
    Dim p As String, f As String, f1 As String, f2 As String
    Dim wb As Workbook, mes1 As Integer, mes2 As Integer
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    mes2 = [C4]: mes1 = mes2 - 1
    p = "C:\Отчеты\": f = Dir(p & "Отчет по " & "????.??.??.xlsx")
    Do While f <> ""
        Select Case Split(f, ".")(1)
            Case Format(mes1, "00"): f1 = IIf(f1 > f, f1, f)
            Case Format(mes2, "00"): f2 = IIf(f2 > f, f2, f)
        End Select
        f = Dir
    Loop
    Set wb = Workbooks.Open(p & f1): [D6:F114].Copy
    Workbooks("Отчет за месяц.xlsm").Sheets(1).[D6].PasteSpecial xlPasteValues
    wb.Close False
    Set wb = Workbooks.Open(p & f2): [D6:F114].Copy
    Workbooks("Отчет за месяц.xlsm").Sheets(1).[G6].PasteSpecial xlPasteValues
    wb.Close False
End Sub
Чем шире угол зрения, тем он тупее.
 
 
 
#11
08.08.2016 18:52:40
Всем спасибо!
 
 
 
Страницы: 1
Наверх