Добрый день!
На вашем форуме новичок и хочу испытать свое счастье.
А для полного счастья мне требуется следующее.
Имеется рабочая книга с тремя листами. В этой книге написан код для отправки книги в архив. Код работающий и притензий к нему у меня нет нет.
Но вот незадача! В каждом месяце, этот код «прячет» в архив целую книгу. То есть, книгу с полным набором имеющихся в ней листов. А мне бы хотелось, чтобы макрос отправлял в архив только отдельный лист рабочей книги, указанный пользователем в ячейке К6 (см. лист Списки).
Плиз! Кто знает как это сделать? Можно предлагать свои варианты решения проблемы.
С уважением, Муля!
Файл с примером зденсь: http://slil.ru/29483043
Как создать архив?
Страница: 1
Сообщений 1 страница 25 из 25
Поделиться12010-07-20 17:17:28
Поделиться22010-07-20 21:34:39
Здравствуйте.
Например так - в М6 номер или название листа, всё равно.
Код:
Sub Архив()
Application.ScreenUpdating = False
PT = Range("I6") & ":\" & Range("J6") & "\" & Range("K6") & ".xls"
sh_ = [m6]
With Workbooks.Add
ThisWorkbook.Sheets(sh_).Copy Before:=.Sheets(1)
Application.DisplayAlerts = False
For Each sh In .Sheets
If sh.Index > 1 Then sh.Delete
Next
Application.DisplayAlerts = True
.SaveCopyAs PT
.Close False
MsgBox "АРХИВ СОЗДАН !"
End With
Application.ScreenUpdating = True
End SubПоделиться32010-07-20 22:56:02
Ув. Hugo доброй вам ночи!
Ваш кодракботает, но в архиве накладает новый лист на старый. А мне нужно, чтобы добавлял в книгу новый лист.
Спасибо!
Поделиться42010-07-20 23:03:16
Я понял, что надо архивировать по одному листу в месяц в новый файл. Мой код не накладывает, он заменяет файл полностью.
Подумаю попозже, наверное завтра к вечеру.
P.S.Хотя тут несложно, уже сделал:
Код:
Sub Архив3()
Dim newflag As Boolean
Dim wb As Workbook
Application.ScreenUpdating = False
PT = Range("I6") & ":\" & Range("J6") & "\" & Range("K6") & ".xls"
sh_ = [m6]
On Error Resume Next
Set wb = Workbooks.Open(PT)
If wb Is Nothing Then
Set wb = Workbooks.Add
newflag = True
End If
On Error GoTo 0
With wb
ThisWorkbook.Sheets(sh_).Copy after:=.Sheets(.Sheets.Count)
If newflag Then
Application.DisplayAlerts = False
For Each sh In .Sheets
If .Sheets.Count > 1 Then sh.Delete
Next
Application.DisplayAlerts = True
.SaveAs PT
.Close False
Else
.Close True
End If
MsgBox "АРХИВ СОЗДАН !"
End With
Application.ScreenUpdating = True
End SubПоделиться52010-07-22 01:34:31
Доброй ночи , а может уже доброе утро, ув. Hugo !
Протестировал код. Первый лист из рабочей книги, он копирует быстро и без проблем. А вот при копировании следующего - сначала просит подтверждения на сохранение всех (по очереди) имен, которые содержат формулы листа, и лишь потом, отправляет лист в архив. Ну очень надоедливая и раздражающая процедура многократного щелканья мышкой.
А нельзя ли эту процедуру как то обойти или хотя бы упростить до минимума. Хотябы до одного щелчка мыши?
Заранее спасибо!
Поделиться62010-07-22 09:56:55
Попробуйте перенести/расставить строки
Application.DisplayAlerts = False
и
Application.DisplayAlerts = True
по краям цикла копирования/сохранения.
Поделиться72010-07-23 10:33:25
Hugo написал(а):
Попробуйте перенести/расставить строки
Application.DisplayAlerts = False
и
Application.DisplayAlerts = True
по краям цикла копирования/сохранения.
Добрый день!
Попробовал, ничего не выщло
Поделиться82010-07-23 11:30:23
Так?
Код:
Sub Архив3()
Dim newflag As Boolean
Dim wb As Workbook
Application.ScreenUpdating = False
PT = Range("I6") & ":\" & Range("J6") & "\" & Range("K6") & ".xls"
sh_ = [m6]
On Error Resume Next
Set wb = Workbooks.Open(PT)
If wb Is Nothing Then
Set wb = Workbooks.Add
newflag = True
End If
On Error GoTo 0
With wb
Application.DisplayAlerts = False
ThisWorkbook.Sheets(sh_).Copy after:=.Sheets(.Sheets.Count)
If newflag Then
For Each sh In .Sheets
If .Sheets.Count > 1 Then sh.Delete
Next
.SaveAs PT
.Close False
Else
.Close True
End If
Application.DisplayAlerts = True
MsgBox "АРХИВ СОЗДАН !"
End With
Application.ScreenUpdating = True
End SubПоделиться92010-07-23 14:06:10
Ув. Hugo!
Я дико перед вами извиняюсь, но возникло непредвиденное обстоятельство.
Дело в том, что теперь код работает, так как я и хотел. За исключением случая, когда в наименовании листа, стоит дата. Например так : 07.2010 или 7.2010. Ругается на строке : ThisWorkbook.Sheets(sh_).Copy after:=.Sheets(Sheets.Count)
А обзывать листі именно так, приходится из-за того, чтобы не было накладок с имеками , в следующем году.
Можно ли с этим как то бороться?
И простите меня пожалуйста за то, что я об этом не вспомнил раньше!
С ув. Муля!
Поделиться102010-07-23 14:40:46
Я сейчас проверил - обозвал лист 07.2010 - работает. Только, чтоб Эксель по-своему не переделывал, поставил этой ячейке (где пишем имя листа) текстовый формат. Да, надо писать именно имя листа, с номером не работает, тогда надо код чуть менять.
Поделиться112010-07-23 16:13:28
Может так будет работать?
Код:
ThisWorkbook.Sheets(sh_).Copy after:=.Sheets(.Sheets.Count)
Думаю листы считать все же нужно в той же книге, в которую добавляем...
Поделиться122010-07-23 16:58:19
Так листы со всяким, в том числе и комбинированым названием (буквы + цифры + знак подчеркивания) копирует без проблем, но при открытии созданого архива просит обновить какие то связи. Которых, по идее, быть не должно! Так мне кажется.
Поделиться132010-07-23 17:49:58
Дмитрий, спасибо за замечание, действительно недоглядел, сейчас выше код подправлю.
Ну если на листе были связи, то они и скопируются со всем листом. Как кстати и макросы листа. Если их надо убрать, то... мне надо потренироваться сперва, 
вот может Дмитрий скажет точно, там что-то вроде
'обрываем связи
ThisWorkbook.BreakLink Name:=iFile, Type:=xlExcelLinks
надо прописать.
P.S. Вот код нашёл:
Код:
Разорвать связь aLinks = ActiveWorkbook.LinkSources(xlExcelLinks) If Not IsEmpty(aLinks) Then For i = 1 To UBound(aLinks) ActiveWorkbook.BreakLink _ Name:=aLinks(i), _ Type:=xlLinkTypeExcelLinks MsgBox "Link " & i & ":" & Chr(13) & aLinks(i) Next i End If
Это надо вставить после того, как лист скопирован в архив.
Поделиться142010-07-23 18:44:47
Не а! Не разріваются. Может я че не так делаю. Но пробовал по всякому
Поделиться152010-07-23 22:04:11
Я тоже пробую - связи из формул разрывает, но после копирования появляется связь с исходной книгой, которая не разрывается...
Поделиться162010-07-25 18:04:20
Есть такой вариант - ссылки не обрываются, но отключается их обновление. Данные остаются те, которые были в момент копирования. На 2000 не работает! Во-первых, на 2000 не работет код, а во-вторых на 2000 остаётся запрос на обновление связей.
Код:
Sub Архив()
Dim newflag As Boolean
Dim wb As Workbook
Application.ScreenUpdating = False
PT = Range("I6") & ":\" & Range("J6") & "\" & Range("K6") & ".xls"
sh_ = [m6]
Application.DisplayAlerts = False
On Error Resume Next
Set wb = Workbooks.Open(PT)
If wb Is Nothing Then
Set wb = Workbooks.Add
newflag = True
End If
On Error GoTo 0
With wb
ThisWorkbook.Sheets(sh_).Copy after:=.Sheets(.Sheets.Count)
wb.UpdateLinks = xlUpdateLinksNever
If newflag Then
For Each sh In .Sheets
If .Sheets.Count > 1 Then sh.Delete
Next
.SaveAs PT
.Close False
Else
.Close True
End If
Application.DisplayAlerts = True
MsgBox "АРХИВ СОЗДАН !"
End With
Application.ScreenUpdating = True
End SubПоделиться172010-07-25 19:04:56
Может, вообще формулы убрать? Все-таки, архивные файлы служат для просмотра и печати, так ведь?
Например, вместо строчки
wb.UpdateLinks = xlUpdateLinksNever
пишем
With ActiveWorkbook.ActiveSheet.UsedRange: .Value = .Value: End With
Поделиться182010-07-27 15:19:15
Добрый день ребята!
Протестировал оба варианта, работают. Ув. Hugo , если у вас появится более изящное решение, то напишите, пожалуйста, его на форуме.
А пока, Большущее вам спасибо за промощь и терпение!!!!!!
Поделиться192010-07-27 22:47:30
Я бы чуть переделал код Hugo(надеюсь он не против)
Код:
Sub Архив()
Dim wb As Workbook, newflag As Boolean, lShNewWBCount As Long, PT As String, sh_ As String
Application.ScreenUpdating = False:Application.DisplayAlerts = False
PT = Range("I6") & ":\" & Range("J6") & "\" & Range("K6") & ".xls"
sh_ = [m6]
If Dir(PT, vbDirectory) <> "" Then
Set wb = Workbooks.Open(PT)
Else
lShNewWBCount = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set wb = Workbooks.Add
Application.SheetsInNewWorkbook = lShNewWBCount
End If
With wb
ThisWorkbook.Sheets(sh_).Copy after:=.Sheets(.Sheets.Count)
wb.UpdateLinks = 2
'Здесь можно вместо установления необновления связей тупо заменить на значения:
'.Sheets(2).usedrange.value=.Sheets(2).usedrange.value
If newflag Then
.Sheets(1).Delete
.SaveAs PT
End If
.Close True
Application.DisplayAlerts = True:Application.ScreenUpdating = True
MsgBox "АРХИВ СОЗДАН !"
End With
End SubПоделиться202010-07-28 00:04:54
The_Prist!
Так он же переносит в архив книгу с двумя листами . И каждый раз создает новую. А мне нужно чтобы создавал пустую книгу и в нее переносил заполненые листы.
С ув. Муля!
Поделиться212010-07-28 10:19:07
Муля2010 написал(а):
Так он же переносит в архив книгу с двумя листами . И каждый раз создает новую.
Что-то я не нашел, где это мой код каждый раз создает новую книгу. Он создает новую, если книги, по указанному пути(Range("I6") & ":\" & Range("J6") & "\" & Range("K6") & ".xls"
) нет. А если есть, то он открывает её и в неё копирует.
Правда, я забыл одну строку:
Код:
Sub Архив()
Dim wb As Workbook, newflag As Boolean, lShNewWBCount As Long, PT As String, sh_ As String
Application.ScreenUpdating = False: Application.DisplayAlerts = False
PT = Range("I6") & ":\" & Range("J6") & "\" & Range("K6") & ".xls"
sh_ = [m6]
If Dir(PT, vbDirectory) <> "" Then
Set wb = Workbooks.Open(PT)
Else
lShNewWBCount = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set wb = Workbooks.Add
Application.SheetsInNewWorkbook = lShNewWBCount
newflag = True
End If
With wb
ThisWorkbook.Sheets(sh_).Copy after:=.Sheets(.Sheets.Count)
wb.UpdateLinks = 2
'Здесь можно вместо установления необновления связей тупо заменить на значения:
'.Sheets(2).usedrange.value=.Sheets(2).usedrange.value
If newflag Then
.Sheets(1).Delete
.SaveAs PT, 56
End If
.Close True
Application.DisplayAlerts = True: Application.ScreenUpdating = True
MsgBox "АРХИВ СОЗДАН !"
End With
End SubТак будет верно.
Поделиться222010-07-28 13:30:09
День добрый вам!
А теперь ругается на строке:.SaveAs PT, 56
Поделиться232010-07-28 15:32:57
Замените 56 на xlNormal или на xlExcel8
Отредактировано The_Prist (2010-07-28 15:33:27)
Поделиться242010-07-28 15:51:09
Теперь все работает четко. СПАСИБО вам большущее The_Prist!
Поделиться252010-07-28 17:59:58
Я не против
Так конечно будет лучше.
Страница: 1