Доброго дня уважаемые гуру EXCELя ! Долго мучался много читал, но результат застрял как вкопаный. Суть макроса - при нажатии кнопки 4, должна создатся папка если она отсутствует в папке ССС на рабочем столе с именем "dd.mm.yyyy_сменные задания" (дата текущая) и копия активного листа "Сменное задание" (если не трудно то область А1:N28) должна сохраниться как отдельная книга без кнопок и формул под именем "дата (из ячейки C3(не всегда текущая дата))_Фамилия (из ячейки D5).xls, в уже созданную папку. Снизу то, до чего я дошел, может и много лишнего, я не ас, но папка создается, файл тоже, проблема что они живут параллельно. Помогите всунуть начинку в обёртку.
[vba]
Код
Sub Кнопка4_Щелчок() Dim PathToSave As String, FolderName As String, FellPathToSave As String Dim fs As Object PathToSave = "C:\Users\Александр\Desktop\ССС\" FolderName = CStr(Format(DateAdd("m", 0, Now), "dd.mm.yyyy") & "_Сменные задания") FellPathToSave = PathToSave & FolderName & "\" Set fs = CreateObject("Scripting.FileSystemObject") If Not fs.FolderExists(FellPathToSave) Then fs.CreateFolder (FellPathToSave) End If 'создали папку
Доброго дня уважаемые гуру EXCELя ! Долго мучался много читал, но результат застрял как вкопаный. Суть макроса - при нажатии кнопки 4, должна создатся папка если она отсутствует в папке ССС на рабочем столе с именем "dd.mm.yyyy_сменные задания" (дата текущая) и копия активного листа "Сменное задание" (если не трудно то область А1:N28) должна сохраниться как отдельная книга без кнопок и формул под именем "дата (из ячейки C3(не всегда текущая дата))_Фамилия (из ячейки D5).xls, в уже созданную папку. Снизу то, до чего я дошел, может и много лишнего, я не ас, но папка создается, файл тоже, проблема что они живут параллельно. Помогите всунуть начинку в обёртку.
[vba]
Код
Sub Кнопка4_Щелчок() Dim PathToSave As String, FolderName As String, FellPathToSave As String Dim fs As Object PathToSave = "C:\Users\Александр\Desktop\ССС\" FolderName = CStr(Format(DateAdd("m", 0, Now), "dd.mm.yyyy") & "_Сменные задания") FellPathToSave = PathToSave & FolderName & "\" Set fs = CreateObject("Scripting.FileSystemObject") If Not fs.FolderExists(FellPathToSave) Then fs.CreateFolder (FellPathToSave) End If 'создали папку
Korobkow, загляните в ЭТОТ топик Там я только что решал похожую задачу разными способами. Только в заданном месте сохранялась копия файла, а не создавалась папка. Но для того, чтобы выяснить уникальность имени ПАПКИ в отличие от ФАЙЛА достаточно всего лишь в Dir указать ещё и атрибут vbDirectory (==16).
Korobkow, загляните в ЭТОТ топик Там я только что решал похожую задачу разными способами. Только в заданном месте сохранялась копия файла, а не создавалась папка. Но для того, чтобы выяснить уникальность имени ПАПКИ в отличие от ФАЙЛА достаточно всего лишь в Dir указать ещё и атрибут vbDirectory (==16).Alex_ST
А тот топик, куда я Вам предлагал заглянуть, как раз оттуда, что Вам нужно и растёт - из Макрос Save_Copy_As. Хотя, у Вас вопрос, кажется уже решён и Вы спрашиваете Василича... Тогда извините, что вмешиваюсь. Пилите сами.
А тот топик, куда я Вам предлагал заглянуть, как раз оттуда, что Вам нужно и растёт - из Макрос Save_Copy_As. Хотя, у Вас вопрос, кажется уже решён и Вы спрашиваете Василича... Тогда извините, что вмешиваюсь. Пилите сами.Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Среда, 24.09.2014, 21:01
Alex_ST, Извени но я так и не понял что нужно выдернуть и куда затем это вставить в тот код что уже написан. Твоя манера написания кодов не для моих познаний VBA
Alex_ST, Извени но я так и не понял что нужно выдернуть и куда затем это вставить в тот код что уже написан. Твоя манера написания кодов не для моих познаний VBA Korobkow
Sub Кнопка4_Щелчок() Dim PathToSave As String, FolderName As String, FellPathToSave As String Dim fs As Object PathToSave = "C:\Users\Александр\Desktop\ССС\" FolderName = CStr(Format(DateAdd("m", 0, Now), "dd.mm.yyyy") & "_Сменные задания") FellPathToSave = PathToSave & FolderName & "\" Set fs = CreateObject("Scripting.FileSystemObject") If Not fs.FolderExists(FellPathToSave) Then MkDir (FellPathToSave) ChDir (FellPathToSave) 'указывает новый путь (это если надо) End If 'создали папку
Application.ScreenUpdating = False Sheets.Add.Name = "Лист2" Sheets("Сменное задание").Select Cells.Select Selection.Copy Sheets("Лист2").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Range("A1").Select ActiveSheet.Name = [D5] On Error Resume Next Folder$ = "C:\Users\Александр\Desktop\ССС\" & Sheets("Сменное задание").Range("d20") & "_Сменное задание" & "\" Filename = [D5] & ".xls" Err.Clear: ActiveSheet.Copy: DoEvents If Err Then Exit Sub ActiveWorkbook.SaveAs Filename:=FellPathToSave & sSuff & "_" & [D5] & ".xls" 'если & sSuff & заменить на & Date &, то работает, но без времени ActiveWorkbook.Close False Sheets("Сменные задания").Select Application.DisplayAlerts = False Sheets(Range("D5").Value).Select ActiveWindow.SelectedSheets.Delete Application.ScreenUpdating = True Application.DisplayAlerts = True Range("D5").Select End Sub
[/vba]
Вот что получилось [vba]
Код
Sub Кнопка4_Щелчок() Dim PathToSave As String, FolderName As String, FellPathToSave As String Dim fs As Object PathToSave = "C:\Users\Александр\Desktop\ССС\" FolderName = CStr(Format(DateAdd("m", 0, Now), "dd.mm.yyyy") & "_Сменные задания") FellPathToSave = PathToSave & FolderName & "\" Set fs = CreateObject("Scripting.FileSystemObject") If Not fs.FolderExists(FellPathToSave) Then MkDir (FellPathToSave) ChDir (FellPathToSave) 'указывает новый путь (это если надо) End If 'создали папку
Application.ScreenUpdating = False Sheets.Add.Name = "Лист2" Sheets("Сменное задание").Select Cells.Select Selection.Copy Sheets("Лист2").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Range("A1").Select ActiveSheet.Name = [D5] On Error Resume Next Folder$ = "C:\Users\Александр\Desktop\ССС\" & Sheets("Сменное задание").Range("d20") & "_Сменное задание" & "\" Filename = [D5] & ".xls" Err.Clear: ActiveSheet.Copy: DoEvents If Err Then Exit Sub ActiveWorkbook.SaveAs Filename:=FellPathToSave & sSuff & "_" & [D5] & ".xls" 'если & sSuff & заменить на & Date &, то работает, но без времени ActiveWorkbook.Close False Sheets("Сменные задания").Select Application.DisplayAlerts = False Sheets(Range("D5").Value).Select ActiveWindow.SelectedSheets.Delete Application.ScreenUpdating = True Application.DisplayAlerts = True Range("D5").Select End Sub
Без файла-примера разбираться с кодом не только трудно, но даже запрещено правилами. Ведь Ваш макрос явно привязан к конкретным листам и диапазонам книги. И только Вы знаете структуру книги. Также только Вы знаете, где расположен текст процедуры. Судя по части синтаксиса - в модуле листа, а по другой - в стандартном модуле. Поэтому проверить что-нибудь на практике невозможно. Но грабли, на которые Вы вполне могли наступить, явно лежат в нескольких местах. Ну, к примеру: 1. Вы явно работаете без декларации Option Explicit, поэтому вполне возможно возникновение "левых" переменных. Однако, в начале процедуры почему-то НЕКОТОРЫЕ переменные объявляете. А некоторые - НЕТ! Например, переменные Folder$ , Filename и sSuff у Вас не объявлены, а значит при их первом появлении в процедуре "обнулены". Вот именно потому, что sSuff не только не определена, но и вообще не задана перед использованием в выражении[vba]
Код
ActiveWorkbook.SaveAs Filename:=FellPathToSave & sSuff & "_" & [D5] & ".xls" 'если & sSuff & заменить на & Date &, то работает, но без времени
[/vba]у Вас и не присваивается суффикс - дата и время. Ведь не заданная заранее переменная sSuff - это "пустышка". Ну а по поводу Вашего комментария к этой строке кода: а вместо Date применить Now не пробовали? Но всё равно в Excel'e Date - это число целых суток от 1900 года, а Now - число суток и их долей (часов, минут, секунд) от 1900 года. Поэтому напрямую вставлять Date или Now в формируемый стринг не рекомендуется, т.к. скорее всего вместо даты и времени вставится их цифровое представление (то самое количество от 1900 года). Поэтому-то я как раз перед применением суффикса sSuff в конкатенации (сборке текста из фрагментов) имени задавал тип его и определял значение:[vba]
[/vba] 2. Несколько раз задавая в процедурах одно и то же текстовое значение "C:\Users\Александр\Desktop\ССС\" , Вы существенно усложняете жизнь себе в дальнейшем. Ну представьте себе, что Вы через несколько дней или месяцев передумали и решили, что правильнее было бы разместить папку не на рабочем столе, а, например, где-то в "Мои документы". И что, будете ползать по коду и менять в нескольких местах? Это мало того, что очень не удобно, но и грозит ошибками (лишний пробельчик где-нибудь). 3. У Вас в коде применено несколько разных синтаксисов обращения к объектной модели. Это совсем не хорошо, т.к. в зависимости от места размещения процедуры разными являются и умолчания для разных синтаксисов. Поэтому вполне возможно неожиданное появление не тех результатов, которые Вы ожидали получить. 4. Задавая часть имени файла в ячейке листа, Вы не проверяете текст этой ячейки на отсутствие в нём запрещённых в именах файлов символов /\:*?<>|" Как это делать можно посмотреть там же, куда я Вас уже направлял выше - в ЭТОМ посте функция Function Replace_UnLegalChr$(ByVal sFileName$)
Без файла-примера разбираться с кодом не только трудно, но даже запрещено правилами. Ведь Ваш макрос явно привязан к конкретным листам и диапазонам книги. И только Вы знаете структуру книги. Также только Вы знаете, где расположен текст процедуры. Судя по части синтаксиса - в модуле листа, а по другой - в стандартном модуле. Поэтому проверить что-нибудь на практике невозможно. Но грабли, на которые Вы вполне могли наступить, явно лежат в нескольких местах. Ну, к примеру: 1. Вы явно работаете без декларации Option Explicit, поэтому вполне возможно возникновение "левых" переменных. Однако, в начале процедуры почему-то НЕКОТОРЫЕ переменные объявляете. А некоторые - НЕТ! Например, переменные Folder$ , Filename и sSuff у Вас не объявлены, а значит при их первом появлении в процедуре "обнулены". Вот именно потому, что sSuff не только не определена, но и вообще не задана перед использованием в выражении[vba]
Код
ActiveWorkbook.SaveAs Filename:=FellPathToSave & sSuff & "_" & [D5] & ".xls" 'если & sSuff & заменить на & Date &, то работает, но без времени
[/vba]у Вас и не присваивается суффикс - дата и время. Ведь не заданная заранее переменная sSuff - это "пустышка". Ну а по поводу Вашего комментария к этой строке кода: а вместо Date применить Now не пробовали? Но всё равно в Excel'e Date - это число целых суток от 1900 года, а Now - число суток и их долей (часов, минут, секунд) от 1900 года. Поэтому напрямую вставлять Date или Now в формируемый стринг не рекомендуется, т.к. скорее всего вместо даты и времени вставится их цифровое представление (то самое количество от 1900 года). Поэтому-то я как раз перед применением суффикса sSuff в конкатенации (сборке текста из фрагментов) имени задавал тип его и определял значение:[vba]
[/vba] 2. Несколько раз задавая в процедурах одно и то же текстовое значение "C:\Users\Александр\Desktop\ССС\" , Вы существенно усложняете жизнь себе в дальнейшем. Ну представьте себе, что Вы через несколько дней или месяцев передумали и решили, что правильнее было бы разместить папку не на рабочем столе, а, например, где-то в "Мои документы". И что, будете ползать по коду и менять в нескольких местах? Это мало того, что очень не удобно, но и грозит ошибками (лишний пробельчик где-нибудь). 3. У Вас в коде применено несколько разных синтаксисов обращения к объектной модели. Это совсем не хорошо, т.к. в зависимости от места размещения процедуры разными являются и умолчания для разных синтаксисов. Поэтому вполне возможно неожиданное появление не тех результатов, которые Вы ожидали получить. 4. Задавая часть имени файла в ячейке листа, Вы не проверяете текст этой ячейки на отсутствие в нём запрещённых в именах файлов символов /\:*?<>|" Как это делать можно посмотреть там же, куда я Вас уже направлял выше - в ЭТОМ посте функция Function Replace_UnLegalChr$(ByVal sFileName$)Alex_ST
[/vba]нужно вообще обсуждать особо. Как раз здесь имеется кроме винегрета синтаксисов ещё и явная избыточность кода. Чего Вы хотели этим добиться? Создать новый лист по образу и подобию листа "Сменное задание" и обозвать его значением, занесённым в ячейку D5 ? Ну так всё намного проще делается:[vba]
Код
With Sheets("Сменное задание") .Copy After:=Sheets(.Index) Sheets(.Index + 1).Name = .[D5] End With
[/vba]нужно вообще обсуждать особо. Как раз здесь имеется кроме винегрета синтаксисов ещё и явная избыточность кода. Чего Вы хотели этим добиться? Создать новый лист по образу и подобию листа "Сменное задание" и обозвать его значением, занесённым в ячейку D5 ? Ну так всё намного проще делается:[vba]
Код
With Sheets("Сменное задание") .Copy After:=Sheets(.Index) Sheets(.Index + 1).Name = .[D5] End With
Sub Кнопка4_Щелчок() Dim PathToSave$, FellPathToSave$, FolderName$: PathToSave = "C:\Users\Александр\Desktop\ССС\" FolderName = Format(Now, "yyyy/mm/dd") & "_Сменные задания" FellPathToSave = PathToSave & FolderName & "\" Dim fs As Object Set fs = CreateObject("Scripting.FileSystemObject") If Not fs.FolderExists(FellPathToSave) Then MkDir (FellPathToSave) Application.ScreenUpdating = False Sheets("Сменное задание").Copy With ActiveSheet .Name = .[D5] .DrawingObjects.Delete ActiveWorkbook.SaveAs (FellPathToSave & Format(Now, "yyyy/mm/dd hh-mm'ss''") & " " & Replace_UnLegalChr(.[D5]) & ".xls") End With ActiveWorkbook.Close Application.ScreenUpdating = True End Sub Private Function Replace_UnLegalChr$(ByVal sFileName$) ' замена не допустимых символов в именах файлов Const sUnLegalChr$ = "/\:*?<>|[]""" ' символы, не допустимые в именах файлов Windows Dim i% For i = 1 To Len(sUnLegalChr) sFileName = Replace(sFileName, Mid(sUnLegalChr, i, 1), "_") Next Replace_UnLegalChr = sFileName End Function
[/vba]Процедуру разместите в стандартном модуле, а не в модуле листа. Тогда в модуль листа новой книги не будет копироваться абсолютно не нужный в ней текст процедур. Я ещё добавил бонус - функцию замены недопустимых в именах файлов символов, введённых в [D5], на _ Если Вы вводите название сами и уверены, что запрещённых символов не будет, то функцию можно не применять.
А ещё лучше - так:[vba]
Код
Sub Кнопка4_Щелчок() Dim PathToSave$, FellPathToSave$, FolderName$: PathToSave = "C:\Users\Александр\Desktop\ССС\" FolderName = Format(Now, "yyyy/mm/dd") & "_Сменные задания" FellPathToSave = PathToSave & FolderName & "\" Dim fs As Object Set fs = CreateObject("Scripting.FileSystemObject") If Not fs.FolderExists(FellPathToSave) Then MkDir (FellPathToSave) Application.ScreenUpdating = False Sheets("Сменное задание").Copy With ActiveSheet .Name = .[D5] .DrawingObjects.Delete ActiveWorkbook.SaveAs (FellPathToSave & Format(Now, "yyyy/mm/dd hh-mm'ss''") & " " & Replace_UnLegalChr(.[D5]) & ".xls") End With ActiveWorkbook.Close Application.ScreenUpdating = True End Sub Private Function Replace_UnLegalChr$(ByVal sFileName$) ' замена не допустимых символов в именах файлов Const sUnLegalChr$ = "/\:*?<>|[]""" ' символы, не допустимые в именах файлов Windows Dim i% For i = 1 To Len(sUnLegalChr) sFileName = Replace(sFileName, Mid(sUnLegalChr, i, 1), "_") Next Replace_UnLegalChr = sFileName End Function
[/vba]Процедуру разместите в стандартном модуле, а не в модуле листа. Тогда в модуль листа новой книги не будет копироваться абсолютно не нужный в ней текст процедур. Я ещё добавил бонус - функцию замены недопустимых в именах файлов символов, введённых в [D5], на _ Если Вы вводите название сами и уверены, что запрещённых символов не будет, то функцию можно не применять.Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Четверг, 25.09.2014, 09:56
Alex_ST,Доброго дня! В виду некоторых неудобств немного упростил свой код вышло чтото приемлимое получилось как-то так: [vba]
Код
Private Sub CommandButton4_Click() Dim PathToSave As String, FolderName As String, FellPathToSave As String Dim fs As Object PathToSave = "C:\" FolderName = [C3] & "_Сменные задания" FellPathToSave = PathToSave & FolderName & "\" Set fs = CreateObject("Scripting.FileSystemObject") If Not fs.FolderExists(FellPathToSave) Then MkDir (FellPathToSave) ChDir (FellPathToSave) 'указывает новый путь (это если надо) End If 'создали папку
Alex_ST,Доброго дня! В виду некоторых неудобств немного упростил свой код вышло чтото приемлимое получилось как-то так: [vba]
Код
Private Sub CommandButton4_Click() Dim PathToSave As String, FolderName As String, FellPathToSave As String Dim fs As Object PathToSave = "C:\" FolderName = [C3] & "_Сменные задания" FellPathToSave = PathToSave & FolderName & "\" Set fs = CreateObject("Scripting.FileSystemObject") If Not fs.FolderExists(FellPathToSave) Then MkDir (FellPathToSave) ChDir (FellPathToSave) 'указывает новый путь (это если надо) End If 'создали папку
И ещё пара рекомендаций: 1. Чтобы не было проблем с перемещением файлов не задавайте абсолютный путь, а используйте относительный от пути к текущему файлу. ActiveWorkbook.Path вернёт путь к файлу БЕЗ ПОСЛЕДНЕГО СЛЭША ActiveWorkbook.FullName вернёт полный путь вместе с именем файла и расширением. 2. Чтобы в проводнике Форточек файлы и папки сортировались в нормальном порядке дат и легко было ориентироваться когда количество файлов или папок достигнет нескольких десятков формат записи даты нужно применять ГГГГ-ММ-ДД При чём именно ММ, чтобы месяц отображался двухзначным числом! Тогда файлы и папки при сортировке в папке лягут "по возрасту", а не в перемешку.
И ещё пара рекомендаций: 1. Чтобы не было проблем с перемещением файлов не задавайте абсолютный путь, а используйте относительный от пути к текущему файлу. ActiveWorkbook.Path вернёт путь к файлу БЕЗ ПОСЛЕДНЕГО СЛЭША ActiveWorkbook.FullName вернёт полный путь вместе с именем файла и расширением. 2. Чтобы в проводнике Форточек файлы и папки сортировались в нормальном порядке дат и легко было ориентироваться когда количество файлов или папок достигнет нескольких десятков формат записи даты нужно применять ГГГГ-ММ-ДД При чём именно ММ, чтобы месяц отображался двухзначным числом! Тогда файлы и папки при сортировке в папке лягут "по возрасту", а не в перемешку.Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Четверг, 25.09.2014, 21:13
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
