Сохранить книгу EXCEL в папку по условию

[vladturbo]

Добрый день уважаемые!
Необходимо сохранить книгу в папку, при чем, имя этой папки каждый месяц изменяется. Имя папки состоит из названия месяца, года и обозначения, к примеру Август 2012 Электроэнергия. Макросом необходимо сохранять ежемесячно книги в папку, в сентябре в папку август, в октябре в папку сентябрь и т.д.

Sub Макрос4()
    Cells.Select
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("A1:K48").Select
    Application.CutCopyMode = False
    ActiveSheet.PageSetup.PrintArea = "$A$1:$K$48"
    Range("A1").Select
    ActiveWorkbook.SaveAs FolderName = (Format(DateAdd("m", -1, Now), "mmmm yyyy") & " Ýëåêòðîýíåðãèÿ") \ "ÊFC.xls", _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWindow.Close
    Range("A1").Select
End Sub

[Poltava]

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

Код Выделить Развернуть

Private Function PathExists(Path As String) As Boolean
    On Error Resume Next 'Включаем подавление ошибок
    GetAttr (Path) 'Пытаемся получить атрибуты обьекта
    If Err = 0 Then PathExists = True 'Если атрибут получен обьект существкет
End Function


[kuklp]

В общий модуль:

Код Выделить Развернуть

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Sub www()
    Dim s$: ActiveSheet.Copy
    With ActiveSheet
        .UsedRange.Value = .UsedRange.Value: .PageSetup.PrintArea = "$A$1:$K$48"
        s = ThisWorkbook.Path & "\" & Format(DateAdd("m", -1, Now), "mmmm_yyyy") & "\Электроэнергия\"
        MakeSureDirectoryPathExists s: .SaveAs s & "EFC.xls": .Parent.Close
    End With
End Sub

[vladturbo]

В таком случае начинает ругаться на строку MakeSureDirectoryPathExists s: .SaveAs s & "EFC.xls": .Parent.Close
пишет sub or function not defined

Sub Макрос4()
    Cells.Select
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("A1:K48").Select
    Application.CutCopyMode = False
    ActiveSheet.PageSetup.PrintArea = "$A$1:$K$48"
    Range("A1").Select
    With ActiveSheet
        .UsedRange.Value = .UsedRange.Value: .PageSetup.PrintArea = "$A$1:$K$48"
        s = ThisWorkbook.Path & "\" & Format(DateAdd("m", -1, Now), "mmmm_yyyy") & "\Электроэнергия\"
         MakeSureDirectoryPathExists s: .SaveAs s & "EFC.xls": .Parent.Close
    End With
    Range("A1").Select
End Sub

[Poltava]

Скорее всего Макрос4 и MakeSureDirectoryPathExists расположены в разных модулях либо снимите статус Private с процедуры либо поместите в один модуль хотя испытывать негде так что могу ошибаться.

[kuklp]

Во-первых, я написал Вам полный текст программы. Зачем Вы напихали туда своего мусора? Она и так делает все, что должна делать Ваша программа.
Полный текст того, что я выложил, вставьте в начало общего модуля и запустите Sub www.
Какой у Вас эксель?

[vladturbo]

Прошу прощения, возможно я объяснил не совсем верно!
1. В корне С:\ есть папки, меняющие свое название ежемесячно, название состоит из соответственно меняющейся части (август 2012, сентябрь 2012 и т.д.) и постоянной, обозначающей принадлежность папки. Полное наименование папки Август 2012 Электроэнергия (в Сентябре), Сентябрь 2012 Электроэнергия в Октябре.
2. В первый день месяца, в корне С:\ создается папка Сентябрь 2012 Электроэнергия, папка Август 2012 Электроэнергия остается в корне С:\, однако макрос сохраняет файлы Excel уже в папку Сентябрь 2012 Электроэнергия, и т. д.
3. Сохранять в папку необходимо в таком порядке: Есть рабочая книга (называется допустим "Бла Бла Бла") в рабочей книге несколько листов, при работе на активном листе книги "Бла Бла Бла", при запуске макроса, макрос создает новую книгу, присваивает название новой книги из определенной ячейки рабочего листа, на Лист1 новой книги копирует форматы и значения с рабочего листа книги "Бла Бла Бла" и сохраняет эту книгу в папку Август 2012 Электроэнергия (если работаешь с книгой "Бла Бла Бла" в Сентябре) и Сентябрь 2012 Электроэнергия (если работаешь с книгой "Бла Бла Бла" в Октябре) и т.п.
4. В примере, если работаешь с любым листом (КРОМЕ ЛИСТА "СПИСОК") при запуске макроса4 создается Книга1. Так вот, этой книги надо присвоить наименование из ячейки D14 Листа1 и сохранить эту Книгу, как описано выше!

[kuklp]

Да уж, умеете вы объяснять.  Где у Вас про D14 хоть намек? Где про "В корне С:\ "? И дальше, в примере на всех листах в D14 - Абрикос студия. Это значит, что каждый раз при создании, файл будет перезаписываться новым файлом! Смотрите мой вариант. Макрос один на все листы в модуле Main. Запускается кнопками. Кнопки потом надо удалить и повесить макрос на сочетание клавиш.                     

[vladturbo]

Не совсем то! В активном листе зашиты формулы, при сохранении, книга сохраняется с формулами (а там формулы привязаны к датам и к макросам в частности ячейки G10, D20 и C26). Если сохранять таким способом, соответственно копируются и формулы, а необходимо только форматы и значения! Подпапку "Электроэнергия" в папке "Сентябрь 2012 Электроэнергия" создавать не надо. К ячейке D14 привязан диапазон на листе "СПИСОК", так вот, макрос должен присвоить новой книге имя из ячейки D14 и сохранить эту книгу в папке в корне С:\ в зависимости от текущего месяца. Не копию книги, а в новую книгу на Лист1 скопировать ЗНАЧЕНИЯ и ФОРМАТЫ с активного рабочего листа книги "Аренда Дговора Ресурсы" и сохранить эту книгу под именем из ячейки D14 в папку, как указано выше

[kuklp]

Вы читаете, что я Вам пишу?

И дальше, в примере на всех листах в D14 - Абрикос студия. Это значит, что каждый раз при создании, файл будет перезаписываться новым файлом!

Еще,

Если сохранять таким способом, соответственно копируются и формулы

- неправда, копируется #ИМЯ и только в ячейке C26, потому как это UDF. Это можно поправить так:

Код Выделить Развернуть

Sub www()
   Dim s$: s = [c26]:  ActiveSheet.Copy
   With ActiveSheet
       .[c26] = s
       .UsedRange.Value = .UsedRange.Value: .PageSetup.PrintArea = "$A$1:$K$48"
       s = "c:\" & Format(DateAdd("m", -1, Now), "mmmm_yyyy") & "\" & ActiveSheet.Name & "\"
       MakeSureDirectoryPathExists s: .SaveAs s & "EFC.xls": .Parent.Close
   End With
End Sub
Но как я вижу, Вы легких путей не ищете, посему - удачи!

[vladturbo]

Просто не работает! Дело не в путях:)

[kuklp]

Просто не работает! Дело не в путях:)

Очень содержательно. А раньше было:

Если сохранять таким способом, соответственно копируются и формулы, а необходимо только форматы и значения!

т.е. работало...

[vladturbo]

В модуле зашит макрос (привязан к ячейке С26) при сохранении способом, как Вы предлагаете у меня получается:
1. создается подпапка "Электроэнергия" в папке "Сентябрь 2012 Электроэнергия", а она не должна создаваться, сохранение должно происходить непосредственно в папку "Сентябрь 2012 Электроэнергия".
2. Сохраненный файл именуется как "KFS", а имя файлу должно присваиваться в соответствии с ячейкой D14 (при чем в этой ячейке всплывающий список, который привязан к диапазону на листе "СПИСОК"), соответственно пользователь может изменять значение этой ячейки. Возможно включить проверку и МессагеБокс о том что файл существует, перезаписать? На случай если пользователь забудет изменить наименование.
3. Раньше было все тоже самое. Необходимо в новую книгу скопировать только форматы и значения, книгу сохранить под именем значения ячейки D14, в папке "Сентябрь 2012 Электроэнергия" если текущий месяц Октябрь, в папке "Октябрь 2012 Электроэнергия" если текущий месяц Ноябрь и т.д.

[vladturbo]

Если запустить этот код:
Sub Макрос4()
    Cells.Select
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("A1:K48").Select
    Application.CutCopyMode = False
    ActiveSheet.PageSetup.PrintArea = "$A$1:$K$48"
    Range("A1").Select
       ActiveWindow.Close
End Sub
Все прекрасно работает до момента сохранения "Книги1" в папке Сентябрь (или Октябрь, или Август) 2012 Электроэнергия под именем из ячейки D14

[Poltava]

Посмотрите этот файл. Немного переделал код от KuklP
- теперь нет привязки к С26 (но должно быть не более 1 вызова функции руб на листе )
- имя папки соответствует названию активного листа и дате
- имя файла берется из ячейки D14
- в результирующем файле удален список из ячейки D14
- при наличии файла выдает запрос о замене(подкорректировал чтоб не вылетало при отказе)
- сохраняет теперь всегда в 2003 офисе, а не в той версии в которой сейчас открыт файл
Макрос будет работать для любого листа в книге создавая для каждого соответствующую папку