Сохранение диапозонна с данными в другую книку

[staniiislav]

Разобрался! надо было добавить (выделил жирным), теперь правильно работатет!
Sub cells1()
Dim irow As Long, iyear As String, t As Object, Response
Application.ScreenUpdating = False: Set Wbmain = ActiveWorkbook: iyear = CStr(Year([a1])): idate = [a1]
Workbooks.Open (ActiveWorkbook.Path & "\Archive\" & "БД.xls"): On Error GoTo Handler
With Workbooks("БД.xls").Sheets(iyear): .Activate
Set t = [a:a].Find(idate, LookIn:=xlValues)
If Not t Is Nothing Then
firstAddress = t.Address
Do
Response = MsgBox("Совпадение даты. Заменить диапазон?", vbOKCancel)
If Response = vbOK Then
Wbmain.ActiveSheet.Range("a1:e16"). Copy Range(t.Address).Offset(0, 0)
End If
Set t = [a:a].FindNext(t)
Loop While Not t Is Nothing And t.Address <> firstAddress
Else

If .[a1] = "" Then
Wbmain.ActiveSheet.Range("a1:e16"). Copy .[a1]
Else
Wbmain.ActiveSheet.Range("a1:e16"). Copy .Cells(.[b:b].Find("", after:=[b1]).Row, "a")
End If: On Error GoTo 0: With Workbooks("БД.xls"): .Save: .Close: End With:
End If: End With
Workbooks("БД.xls").Close
If MsgBox("Сохранить?", vbYesNo, "Подтверждение") = vbYes Then
FolderName = Wbmain.Path & "\Archive"
On Error Resume Next
MkDir FolderName
Date_name = Range("a1")
fg_ = Format(Date_name, "yyyy")
fm_ = Format(Date_name, "mmmm")
If Date_name <> Empty Then
If ActiveSheet.Visible = -1 Then
ActiveSheet.Copy
Set Wb = ActiveWorkbook
Wb.SaveAs FolderName & "\" & fg_ & "\" & fm_ _
& "\" & Wb.Sheets(1).Name & " (" & Date_name & ").xls", xlNormal
Wb.Close False
End If
MsgBox "Лист " & ActiveSheet.Name & " в виде одного файла сохранен в папку " & FolderName
End If
Application.EnableEvents = True
Else
End If
Exit Sub
Handler:
MsgBox "Лист с таким годом не найден"
End Sub

но еще нужно чтобы сохраняло в документ БД, если лист защищен. Подскажите пожалуйста как это сделать?
nilem, я просто не понял что вы в своем макросе удаляли, добавляли? нужно ли это в данном примере (выложил)?

Тфу блин, теперь сохранение не работает, зато замена правильно работает... сейчас буду разбератся

[staniiislav]

Фух... Как фигово когда языков программирования не знаешь... сделал, выделяю жирным какую строку вставил и куда

Sub cells1()
Dim irow As Long, iyear As String, t As Object, Response
Application.ScreenUpdating = False: Set Wbmain = ActiveWorkbook: iyear = CStr(Year([a1])): idate = [a1]
Workbooks.Open (ActiveWorkbook.Path & "\Archive\" & "БД.xls"): On Error GoTo Handler
With Workbooks("БД.xls").Sheets(iyear): .Activate
Set t = [a:a].Find(idate, LookIn:=xlValues)
If Not t Is Nothing Then
firstAddress = t.Address
Do
Response = MsgBox("Совпадение даты. Заменить диапазон?", vbOKCancel)
If Response = vbOK Then
Wbmain.ActiveSheet.Range("a1:e16"). Copy Range(t.Address).Offset(0, 0)
End If
Set t = [a:a].FindNext(t)
Loop While Not t Is Nothing And t.Address <> firstAddress
Else

If .[a1] = "" Then
Wbmain.ActiveSheet.Range("a1:e16"). Copy .[a1]
Else
Wbmain.ActiveSheet.Range("a1:e16"). Copy .Cells(.[b:b].Find("", after:=[b1]).Row, "a")
End If: On Error GoTo 0
With Workbooks("БД.xls"): .Save: .Close: End With:
End If: End With
If MsgBox("Сохранить?", vbYesNo, "Подтверждение") = vbYes Then
FolderName = Wbmain.Path & "\Archive"
On Error Resume Next
MkDir FolderName
With Workbooks("БД.xls"): .Save: .Close: End With:
Date_name = Range("a1")
fg_ = Format(Date_name, "yyyy")
fm_ = Format(Date_name, "mmmm")
If Date_name <> Empty Then
If ActiveSheet.Visible = -1 Then
ActiveSheet.Copy
Set Wb = ActiveWorkbook
Wb.SaveAs FolderName & "\" & fg_ & "\" & fm_ _
& "\" & Wb.Sheets(1).Name & " (" & Date_name & ").xls", xlNormal
Wb.Close False
End If
MsgBox "Лист " & ActiveSheet.Name & " в виде одного файла сохранен в папку " & FolderName
End If
Application.EnableEvents = True
Else
End If
Exit Sub
Handler:
MsgBox "Лист с таким годом не найден"
End Sub

Теперь вроде правильно!

но еще нужно чтобы сохраняло в документ БД, если лист защищен. Подскажите пожалуйста как это сделать?
nilem, я просто не понял что вы в своем макросе удаляли, добавляли? нужно ли это в данном примере (выложил)?

[nilem]

Вы мой вариант, похоже, не смотрели.
Защиту можно снять так (пароль - 123):

With Workbooks("БД.xls").Sheets(iyear)
    .Unprotect "123"
   .........
    .Protect "123"
End With

[staniiislav]

я наверно уже достал? если так, так и скажите!
но вылезла еще одна проблема
надо чтобы макрос еще кое что проверял... не только совпадение по дате из столбца А1 но еще и значение в столбе В1. А именно, если значение А1 повторяется в БД, делается еще и проверка по В1 на совпадение. И если есть совпадения хоть в А1 хоть в В1, А1 и В1 должны находиться на одной строке, только тогда проводить замену данных, в противном случаи просто сохранять в БД (и на отдельный лист) данные.
Как это будет выглядеть:
А1=01.01.2010, В1= Пт1--- нажимаем сохранить, сохраняется в БД и на отдельный лист в зависимости от даты, затем
А1=01.01.2010, В1= Пт2 ---- опять происходит сохранение в БД на отдельный лист в зависимости от даты, затем
А1=01.01.2010, В1=Пт1 --- нажимаем сохранить, и выскакивает диалоговое окно "Совпадение даты. Заменить диапазон?", нажимает заменить(или нет), и выскакивает второе диалоговое окно "Сохранить?", нажимает заменить (или нет)
Извиняюсь за назойливость, но очень нужна Ваша помощь, сам не разберусь.
Спасибо! С Ув. Staniiislav

[staniiislav]

Сообщение от nilem

Вы мой вариант, похоже, не смотрели.
Защиту можно снять так (пароль - 123):

With Workbooks("БД.xls").Sheets(iyear)
    .Unprotect "123"
   .........
    .Protect "123"
End With

Вы не правы, я вчера пол вечера разбирал Ваш вариант, я просто не программист, только начинаю немного разбираться, я попробовал немного переделать ваш макрос, у меня не получилось... Вернулся к старому варианту, т.к. сроки поджимают...

[nilem]

Участие требуется?
Вот переписал, проверил: в БД перезаписывается (сравниваем 2 ячейки), в новый файл тоже копируется с нормальным названием.

Option Explicit

Sub cells2()    'staniislav
Dim iyear As String, idate As Date, adr As String, Fname As String
Dim Wbmain As Object, wb As Object, x, i As Long, fg_ As String, fm_ As String
Application.ScreenUpdating = False

Set Wbmain = ThisWorkbook: iyear = CStr(Year([a1])): idate = [a1]
Workbooks.Open (ThisWorkbook.Path & "\Archive\БД.xls"): On Error GoTo Handler
With Workbooks("БД.xls").Sheets(iyear)
    .Unprotect "123"
    x = .Range("A1:E" & .Cells(Rows.Count, 3).End(xlUp).Row).Value
    For i = 1 To UBound(x, 1) Step 16
        If x(i, 1) = idate And x(i, 2) = ThisWorkbook.Sheets(1).[b1] Then
            If MsgBox("Совпадение даты. Заменить диапазон?", vbYesNo) = vbYes Then
                Wbmain.Sheets(1).Range("A1:E16").Copy .Range("A" & i)
            End If: Exit For
        End If
    Next i
    If UBound(x, 1) = 1 Then
        Wbmain.Sheets(1).Range("A1:E16").Copy .Range("A1")
    ElseIf i > UBound(x, 1) Then
        Wbmain.Sheets(1).Range("A1:E16").Copy .Range("A" & i)
    End If
    .Range("A" & i).Value = .Range("A" & i).Value: .Protect "123"
    On Error GoTo 0
End With
With Workbooks("БД.xls"): .Close True: End With

If MsgBox("Сохранить лист?", vbYesNo, "Подтверждение") = vbYes Then
    Fname = Wbmain.Path & "\Archive"
    On Error Resume Next
    MkDir Fname
    fg_ = Format(idate, "yyyy"): fm_ = Format(idate, "mmmm")
    If idate <> Empty Then
        If ActiveSheet.Visible = -1 Then
            ActiveSheet.Copy
            Set wb = ActiveWorkbook
            wb.Sheets(1).Shapes(1).Delete
            wb.SaveAs Fname & "\" & fg_ & "\" & fm_ _
                      & "\" & wb.Sheets(1).Name & " (" & idate & ").xls", xlNormal
            wb.Close
        End If
        MsgBox "Лист " & ActiveSheet.Name & " в виде файла сохранен в папку " & Fname
    End If
End If
Application.ScreenUpdating = True
Exit Sub
Handler:
MsgBox "Лист с таким годом не найден" & vbCrLf & _
       Err.Description
End Sub

Не забудьте переназначить cells2 на кнопку.

[staniiislav]

Всегда требуется ))) Спасибо огромное, буду тестить дома уже, сегодня ночь ))) Обязательно отпишусь о содеяном )))
Надею нечего не забыл, и это будет последнее изменение спасибо!

[staniiislav]

Ув. nilem, не могу до конца проверить, так как сохраняется только первый лист в книге, а у меня не один лист... как подправить подскажите пожалуйста.
А вообще вроде работает так как надо!
С Ув. Staniiislav

[nilem]

Сообщение от staniiislav

... сохраняется только первый лист в книге, а у меня не один лист...

Вот об этом речь?

If MsgBox("Сохранить лист?", vbYesNo, "Подтверждение") = vbYes Then

Т.е. надо сохранять не один активный лист, а всю книгу? Или определенные листы из книги? Или что-то еще?

[staniiislav]

Стоп! Я не правильно выразился, листы сохраняются нормально в /архиве/2010/.../ а вот в БД сохраняются данные только с первого листа, а должны сохраняться с разных листов...Допустим я на 15 листе, и нажимаю кнопку сохранить, должно произойти сохранение диапазона А1:Е16 с 15 листа в книгу БД(если такая дата в А и значение в В уже существует, спрашивается заменить или нет), и сохраниться отдельным листом(в зависимости какая стоит дата) в директорию /архиве/2010/.../.А сейчас сохраняются только данные с Лист1 диапозона А1:Е16 в книгу БД, а а /архиве/ нормально сохраняются листы в зависимости от даты! Извиняюсь, вчера уже засыпал когда писал на форуме