копирование отдельного листа в новую книгу - Мир MS Excel

Регистрация

Напомнить пароль

= Мир MS Excel/копирование отдельного листа в новую книгу - Мир MS Excel

Старая форма входа

Страница 1 из 2 1 2 »
Модератор форума: китин, _Boroda_

копирование отдельного листа в новую книгу

копирование отдельного листа в новую книгу

Дата: Вторник, 30.08.2011, 03:22 | Сообщение № 1

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 134

Репутация: 6 ±

Замечаний: 0% ±

можно ли сделать чтобы при закрытии книги лист1 копировался в другую книгу, где создавался бы лист с именем равным текущей даты? а если лист уже существует то данные обновляются или заменяются.
и если такое возможно, то можно ли копировать лист не при каждом закрытии книги, а с условием что на Листе1 делались изменения?

Ответить

Дата: Вторник, 30.08.2011, 14:49 | Сообщение № 2

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3213

Репутация: 609 ±

Замечаний: 0% ±

2003

Quote (AKSENOV048)

сделать чтобы при закрытии книги

- в модуле ЭтаКнига процедура

Code

Private Sub Workbook_BeforeClose(Cancel As Boolean)

Quote (AKSENOV048)

…лист1 копировался в другую книгу…

это куда? Где лежит эта книга, если она ещё не открыта или как как её зовут если она уже открыта?

Quote (AKSENOV048)

…создавался бы лист с именем равным текущей даты? а если лист уже существует то данные обновляются или заменяются…

ну, это совсем не сложно. Воспользуйтесь макрорекордером и всё сами поймёте

Quote (AKSENOV048)

копировать лист не при каждом закрытии книги, а с условием что на Листе1 делались изменения?

а вот тут могут возникнуть проблемы. Узнать-то перед закрытием, вносились ли какие-нибудь изменения в книгу достаточно просто:

Code

If ThisWorkbook.Saved Then…

а вот выяснить, на каком листе были изменения??? Я не знаю как.

С уважением,
Алексей
MS Excel 2003 - the best!!!

Сообщение отредактировал Alex_ST - Среда, 31.08.2011, 13:32

Ответить

Дата: Вторник, 30.08.2011, 18:56 | Сообщение № 3

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 134

Репутация: 6 ±

Замечаний: 0% ±

Спасибо Alex ST за ответ.

Quote (Alex_ST)

это куда? Где лежит эта книга, если она ещё не открыта или как как её зовут если она уже открыта?

в эту же папку, где и исходная книга. "новая" книга закрыта. название любое, допустим Архив.

Ответить

Дата: Суббота, 03.09.2011, 15:42 | Сообщение № 4

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 134

Репутация: 6 ±

Замечаний: 0% ±

Добрый день!
вот макрос который делает резервную копию всей книги при выходе из нее.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim x As String
strPath = "C:\Users\Александр\Desktop\архив\магазин"
On Error Resume Next
x = GetAttr(strPath) And 0
If Err = 0 Then ' если путь существует - сохраняем копию книги
strDate = Format(Date, "dd/mm/yy")
FileNameXls = strPath & "\" & Left(Sheets(1).Name, _
Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".xlsm"
ActiveWorkbook.SaveCopyAs Filename:=FileNameXls
Else 'если путь не существует - выводим сообщение
MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical
End If
End Sub

можно ли как то его переделать в такой план:
.....
strPath1 = "C:\Users\Александр\Desktop\архив\магазин"
strPath4 = "C:\Users\Александр\Desktop\архив\реализация корея"
strPath7 = "C:\Users\Александр\Desktop\архив\реализация бишкек"
FileNameXls1 = strPath & "\" & Left(Sheets(1).Name, _ Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".xlsm"
FileNameXls4 = strPath & "\" & Left(Sheets(4).Name, _ Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".xlsm"
FileNameXls7 = strPath & "\" & Left(Sheets(7).Name, _ Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".xlsm"
ActiveWorkbook.Sheets(1).SaveCopyAs Filename:=FileNameXls1
ActiveWorkbook.Sheets(4).SaveCopyAs Filename:=FileNameXls4
ActiveWorkbook.Sheets(7).SaveCopyAs Filename:=FileNameXls7
....

я что то не правильно делаю.
перестает работать когда я заменяю ActiveWorkbook.SaveCopyAs Filename:=FileNameXls на ActiveWorkbook.Sheets(1).SaveCopyAs Filename:=FileNameXls1 или Sheets(1).SaveCopyAs Filename:=FileNameXls1

Добрый день!
вот макрос который делает резервную копию всей книги при выходе из нее.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim x As String
strPath = "C:\Users\Александр\Desktop\архив\магазин"
On Error Resume Next
x = GetAttr(strPath) And 0
If Err = 0 Then ' если путь существует - сохраняем копию книги
strDate = Format(Date, "dd/mm/yy")
FileNameXls = strPath & "\" & Left(Sheets(1).Name, _
Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".xlsm"
ActiveWorkbook.SaveCopyAs Filename:=FileNameXls
Else 'если путь не существует - выводим сообщение
MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical
End If
End Sub

можно ли как то его переделать в такой план:
.....
strPath1 = "C:\Users\Александр\Desktop\архив\магазин"
strPath4 = "C:\Users\Александр\Desktop\архив\реализация корея"
strPath7 = "C:\Users\Александр\Desktop\архив\реализация бишкек"
FileNameXls1 = strPath & "\" & Left(Sheets(1).Name, _ Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".xlsm"
FileNameXls4 = strPath & "\" & Left(Sheets(4).Name, _ Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".xlsm"
FileNameXls7 = strPath & "\" & Left(Sheets(7).Name, _ Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".xlsm"
ActiveWorkbook.Sheets(1).SaveCopyAs Filename:=FileNameXls1
ActiveWorkbook.Sheets(4).SaveCopyAs Filename:=FileNameXls4
ActiveWorkbook.Sheets(7).SaveCopyAs Filename:=FileNameXls7
....

я что то не правильно делаю.
перестает работать когда я заменяю ActiveWorkbook.SaveCopyAs Filename:=FileNameXls на ActiveWorkbook.Sheets(1).SaveCopyAs Filename:=FileNameXls1 или Sheets(1).SaveCopyAs Filename:=FileNameXls1AKSENOV048

Ответить

СообщениеДобрый день!
вот макрос который делает резервную копию всей книги при выходе из нее.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim x As String
strPath = "C:\Users\Александр\Desktop\архив\магазин"
On Error Resume Next
x = GetAttr(strPath) And 0
If Err = 0 Then ' если путь существует - сохраняем копию книги
strDate = Format(Date, "dd/mm/yy")
FileNameXls = strPath & "\" & Left(Sheets(1).Name, _
Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".xlsm"
ActiveWorkbook.SaveCopyAs Filename:=FileNameXls
Else 'если путь не существует - выводим сообщение
MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical
End If
End Sub

можно ли как то его переделать в такой план:
.....
strPath1 = "C:\Users\Александр\Desktop\архив\магазин"
strPath4 = "C:\Users\Александр\Desktop\архив\реализация корея"
strPath7 = "C:\Users\Александр\Desktop\архив\реализация бишкек"
FileNameXls1 = strPath & "\" & Left(Sheets(1).Name, _ Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".xlsm"
FileNameXls4 = strPath & "\" & Left(Sheets(4).Name, _ Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".xlsm"
FileNameXls7 = strPath & "\" & Left(Sheets(7).Name, _ Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".xlsm"
ActiveWorkbook.Sheets(1).SaveCopyAs Filename:=FileNameXls1
ActiveWorkbook.Sheets(4).SaveCopyAs Filename:=FileNameXls4
ActiveWorkbook.Sheets(7).SaveCopyAs Filename:=FileNameXls7
....

я что то не правильно делаю.
перестает работать когда я заменяю ActiveWorkbook.SaveCopyAs Filename:=FileNameXls на ActiveWorkbook.Sheets(1).SaveCopyAs Filename:=FileNameXls1 или Sheets(1).SaveCopyAs Filename:=FileNameXls1

Автор - AKSENOV048
Дата добавления - 03.09.2011 в 15:42

Дата: Суббота, 03.09.2011, 21:52 | Сообщение № 5

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3213

Репутация: 609 ±

Замечаний: 0% ±

2003

1. А с чего вы взяли, что у ЛИСТА ActiveWorkbook.Sheets(1) есть метод SaveCopyAs?
Это метод КНИГИ. Поэтому и не работает.
2. И что значит Left(Sheets(1).Name, Len(ActiveWorkbook.Name) - 4)? Что-то я не пойму?
Какая связь ДЛИНЫ имени активной книги без расширения (к стати, 4 - это рассчитано на .xls-файлы, а если всё-таки .xlsm, то должно быть 5) и именем сохраняемой книги? А что, если имя активной книги длиннее имени листа, то имя листа обрезать не надо что ли?(см. справку по функции Left)?

Что вам нужно-то?
Разбить книгу на отдельные файлы по листам?
Ну так запишите действия макрорекордером:
- выберите нужный лист
- сделайте ему по ПКМ на ярлыке листа "Переместить/скопировать" - "Создавать копию" - "В новую книгу"
- эту новую книгу "Сохранить как..."
Я не пойму, вы хотите сами научиться или чтобы за вас кто-то сделал?
Ну попробуйте же сами разобрать макрос, который вы привели...

С уважением,
Алексей
MS Excel 2003 - the best!!!

Сообщение отредактировал Alex_ST - Суббота, 03.09.2011, 21:56

Ответить

Дата: Воскресенье, 04.09.2011, 01:05 | Сообщение № 6

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 134

Репутация: 6 ±

Замечаний: 0% ±

wacko

СПАСИБО. буду знать!

Ответить

Дата: Воскресенье, 04.09.2011, 15:13 | Сообщение № 7

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 134

Репутация: 6 ±

Замечаний: 0% ±

вот то что записал макрорекордером:

Sub Макрос2()
Sheets("МАГАЗИН").Select
Sheets("МАГАЗИН").Copy
ChDir "C:\Users\Александр\Desktop\архив\магазин"
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\Александр\Desktop\архив\магазин\03.09.11.xlsm", FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWindow.Close
End Sub

вот так получается копировать отдельный листы, в разные книги, но они не сохраняются автоматически!
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim x1 As String
Dim x4 As String
Dim x7 As String
strPath1 = "C:\Users\Александр\Desktop\архив\магазин\"
strPath4 = "C:\Users\Александр\Desktop\архив\реализация корея\"
strPath7 = "C:\Users\Александр\Desktop\архив\реализация бишкек\"

On Error Resume Next
x1 = GetAttr(strPath1) And 0
x4 = GetAttr(strPath4) And 0
x7 = GetAttr(strPath7) And 0
If Err = 0 Then ' если путь существует - сохраняем копию книги
strDate = Format(Date, "dd/mm/yy")
FileNameXls1 = strPath1 & strDate & ".xlsm"
FileNameXls4 = strPath4 & strDate & ".xlsm"
FileNameXls7 = strPath7 & strDate & ".xlsm"
Sheets(1).Copy
ActiveWorkbook.SaveCopyAs Filename:=FileNameXls1
Sheets(4).Copy
ActiveWorkbook.SaveCopyAs Filename:=FileNameXls4
Sheets(7).Copy
ActiveWorkbook.SaveCopyAs Filename:=FileNameXls7
Else 'если путь не существует - выводим сообщение
MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical
End If
End Sub

Ответить

Дата: Воскресенье, 04.09.2011, 15:57 | Сообщение № 8

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3690

Репутация: 790 ±

Замечаний: 0% ±

365

Я думаю, что вот тут

Code

strPath = "C:\Users\Александр\Desktop\архив\магазин"
On Error Resume Next
x = GetAttr(strPath) And 0
If Err = 0 Then

определяется, будет ли ошибка при выполнении GetAttr().
Поэтому в куске

Code

On Error Resume Next
x1 = GetAttr(strPath1) And 0
x4 = GetAttr(strPath4) And 0
x7 = GetAttr(strPath7) And 0
If Err = 0

тактически неправильный подход - нужно это дело разбить на 3 отдельных подхода к каждому листу индивидуально. Ведь здесь будет ошибка, если любой из этих путей будет недоступен, и к тому же вот тут

Code

MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical

будет бестолковое сообщение, т.к. переменная strPath не имеет значения.

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Ответить

Дата: Воскресенье, 04.09.2011, 16:07 | Сообщение № 9

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 134

Репутация: 6 ±

Замечаний: 0% ±

On Error Resume Next
x1 = GetAttr(strPath1) And 0
x4 = GetAttr(strPath4) And 0
x7 = GetAttr(strPath7) And 0
If Err = 0
я думаю его вообще можно убрать.?

MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical
не углядел! да и тоже принципе не обязательно.

а все же почему не сохраняются автоматом. я когда нажимаю закрыть, появляется три новых книги, с заголовками Книга 1 , 2 и 3, смотрю в папки там создаются файлы каждый в своей! Книги надо закрывать в ручную и присваивать им имена!

Ответить

Дата: Воскресенье, 04.09.2011, 16:10 | Сообщение № 10

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3690

Репутация: 790 ±

Замечаний: 0% ±

365

SaveCopyAs - это "сохранить как". А "закрыть" нету.

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Ответить

Дата: Воскресенье, 04.09.2011, 16:17 | Сообщение № 11

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3690

Репутация: 790 ±

Замечаний: 0% ±

365

Вроде так (не проверял):

Code

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim x1 As String
Dim x4 As String
Dim x7 As String
strPath1 = "C:\Users\Александр\Desktop\архив\магазин\"
strPath4 = "C:\Users\Александр\Desktop\архив\реализация корея\"
strPath7 = "C:\Users\Александр\Desktop\архив\реализация бишкек\"

strDate = Format(Date, "dd/mm/yy")
FileNameXls1 = strPath1 & strDate & ".xlsm"
FileNameXls4 = strPath4 & strDate & ".xlsm"
FileNameXls7 = strPath7 & strDate & ".xlsm"
Sheets(1).Copy
ActiveWorkbook.SaveAs Filename:=FileNameXls1, FileFormat:= _
xlOpenXMLWorkbookMacroEnabled
ActiveWorkbook.Close False
Sheets(4).Copy
ActiveWorkbook.SaveAs Filename:=FileNameXls4, FileFormat:= _
xlOpenXMLWorkbookMacroEnabled
ActiveWorkbook.Close False
Sheets(7).Copy
ActiveWorkbook.SaveAs Filename:=FileNameXls7, FileFormat:= _
xlOpenXMLWorkbookMacroEnabled
ActiveWorkbook.Close False
End Sub

Или так попрбуй:

Code

Sheets(1).Copy
ActiveWorkbook.Close True, FileNameXls1, FileFormat:= _
xlOpenXMLWorkbookMacroEnabled

Только есть вопрос - зачем как xlsm сохранять? Там в каждом листе макросы прописаны разве?

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Ответить

Дата: Воскресенье, 04.09.2011, 16:33 | Сообщение № 12

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 134

Репутация: 6 ±

Замечаний: 0% ±

работает. только при каждом выключении выдает: "файл ...... уже существует. заменить?" можно как то это обойти, чтобы постоянно заменялось?

Сообщение отредактировал AKSENOV048 - Воскресенье, 04.09.2011, 16:33

Ответить

Дата: Воскресенье, 04.09.2011, 16:34 | Сообщение № 13

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3690

Репутация: 790 ±

Замечаний: 0% ±

365

Application.displayalerts = False
потом в конце обязательно верни назад.

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Ответить

Дата: Воскресенье, 04.09.2011, 16:39 | Сообщение № 14

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 134

Репутация: 6 ±

Замечаний: 0% ±

получилось)) Спасибо Вам Hugo!!!

Quote (Hugo)

Только есть вопрос - зачем как xlsm сохранять? Там в каждом листе макросы прописаны разве?

нет. блин точно.
даже наоборот хотел спросить можно ли чтобы листы копировались без макросов?

Ответить

Дата: Воскресенье, 04.09.2011, 16:42 | Сообщение № 15

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3690

Репутация: 790 ±

Замечаний: 0% ±

365

Если в модуле листе есть макросы, и хотите копировать без них - тогда нужно или переносить данные в другие листы, или удалять проекты типа

Code

For Each VBC In VBProject.VBComponents
VBC.codemodule.deletelines 1, VBC.codemodule.countoflines
End If

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Ответить

Дата: Воскресенье, 04.09.2011, 16:48 | Сообщение № 16

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 134

Репутация: 6 ±

Замечаний: 0% ±

вопрос решился, переменной формата в .xlsx листы сохраняются без макросов.!) вы как всегда правы! спасибо большое.

Сообщение отредактировал AKSENOV048 - Воскресенье, 04.09.2011, 16:49

Ответить

Дата: Воскресенье, 04.09.2011, 16:51 | Сообщение № 17

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3690

Репутация: 790 ±

Замечаний: 0% ±

365

Хотя точно, в 2007/10 хватает просто сохранить в xlsx smile

smile

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Ответить

Дата: Воскресенье, 04.09.2011, 17:01 | Сообщение № 18

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 134

Репутация: 6 ±

Замечаний: 0% ±

еще вопрос. со временем файлов получится много, нашел код удаления файлов созданных 30 дней назад:
Sub УдалениеФайл_Минус_30_Дн()
TargetFolder = "h:\tmp"
ControlDate = Date - 30
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFSO.GetFolder(TargetFolder).Files
If objFile.DateCreated < ControlDate Then
objFSO.DeleteFile objFile.Path
End If
Next
End Sub

можно ввести сразу три папки?
TargetFolder = "C:\Users\Александр\Desktop\архив\магазин\"
TargetFolder = "C:\Users\Александр\Desktop\архив\реализация корея\"
TargetFolder = "C:\Users\Александр\Desktop\архив\реализация бишкек\"

Ответить

Дата: Воскресенье, 04.09.2011, 17:10 | Сообщение № 19

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3690

Репутация: 790 ±

Замечаний: 0% ±

365

Можно конечно создать массив текстовых значений и перебирать в цикле его, но на 3 значения можно тупо так:

Code

Sub УдалениеФайл_Минус_30_Дн()
ControlDate = Date - 30
Set objFSO = CreateObject("Scripting.FileSystemObject")

TargetFolder = "C:\Users\Александр\Desktop\архив\магазин\"
For Each objFile In objFSO.GetFolder(TargetFolder).Files
If objFile.DateCreated < ControlDate Then
objFSO.DeleteFile objFile.Path
End If
Next

TargetFolder = "C:\Users\Александр\Desktop\архив\реализация корея\"
For Each objFile In objFSO.GetFolder(TargetFolder).Files
If objFile.DateCreated < ControlDate Then
objFSO.DeleteFile objFile.Path
End If
Next

TargetFolder = "C:\Users\Александр\Desktop\архив\реализация бишкек\"
For Each objFile In objFSO.GetFolder(TargetFolder).Files
If objFile.DateCreated < ControlDate Then
objFSO.DeleteFile objFile.Path
End If
Next

End Sub

С массивом вероятно так:

Code

Sub УдалениеФайл_Минус_30_Дн()
     ControlDate = Date - 30
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     arr = Array("C:\Users\Александр\Desktop\архив\магазин\", "C:\Users\Александр\Desktop\архив\реализация корея\", "C:\Users\Александр\Desktop\архив\реализация бишкек\")

     For Each TargetFolder In arr
         For Each objFile In objFSO.GetFolder(TargetFolder).Files
             If objFile.DateCreated < ControlDate Then
                 objFSO.DeleteFile objFile.Path
             End If
         Next
     Next

End Sub

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Ответить

Дата: Воскресенье, 04.09.2011, 17:16 | Сообщение № 20

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 134

Репутация: 6 ±

Замечаний: 0% ±

biggrin

возьму второй вариант.! спасибо большое. вопросов больше нету.

изменил всё событие на Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean). то что надо.

Сообщение отредактировал AKSENOV048 - Воскресенье, 04.09.2011, 17:48

Ответить

копирование отдельного листа в новую книгу

Страница 1 из 2
1
2
»

© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!