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

[nilem]

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

... а должны сохраняться со разных листов...

Со разных, так со разных
Смотрите в файле.
Вместо 30 кнопок на листах, может лучше одну кнопку на ленту или в панель быстр. доступа? Одна кнопка будет работать с текущим активным листом.

На всякий случай: предполагается, что у Вас 30 кнопок на листах, и на каждую кнопку назначен один и тот же макрос Sub cells2(). Проверьте.

[staniiislav]

Вроде нашел решение! Посмотрите пожалуйста (что заменил выделил жирным). И там где я подчеркнул, объясните пожалуйста как это работает... я просто пытаюсь понять алгоритм, что за чем следует и как правильно это что написать. Спасибо

Option Explicit

Sub cells1()
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:BM" & .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.ActiveSheet().[b1] Then
If MsgBox("Совпадение даты. Заменить диапазон?", vbYesNo) = vbYes Then
Wbmain.Sheets(1).Range("A1:BM59").Copy .Range("A" & i)
End If: Exit For
End If
Next i
If UBound(x, 1) = 1 Then
Wbmain.ActiveSheet().Range("A1:BM59").Copy .Range("A1")
ElseIf i > UBound(x, 1) Then
Wbmain.ActiveSheet().Range("A1:BM59").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

[staniiislav]

Ооо ))) сейчас и посмотрю правильно ли я сделал или нет ))) Спасибо огромное )))

[staniiislav]

а если создать такую кнопку, она будет появляться и работать на другом компьютере?

[staniiislav]

Спасибо огромное nilem, EugeneS. Без вашей помощи, я бы не справился! Вот так думаю, этот макрос будет итоговым вариантом (добавил еще автофильтр при защищенном листе):

Option Explicit

Sub cells1()
Dim iyear As String, idate As Date, adr As String, Fname As String
Dim Wsh As Worksheet, wb As Object, x, i As Long, fg_ As String, fm_ As String
Application.ScreenUpdating = False

Set Wsh = ThisWorkbook.ActiveSheet: 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:BM" & .cells(Rows.Count, 3).End(xlUp).Row).Value
For i = 2 To UBound(x, 1) Step 59
If x(i, 1) = idate And x(i, 2) = Wsh.[b1] Then
If MsgBox("Совпадение даты. Заменить диапазон в БД?", vbYesNo) = vbYes Then
Wsh.Range("A1:BM59").Copy .Range("A" & i)
End If: Exit For
End If
Next i
If UBound(x, 1) = 1 Then
Wsh.Range("A1:BM59").Copy .Range("A2")
ElseIf i > UBound(x, 1) Then
Wsh.Range("A1:BM59").Copy .Range("A" & i)
End If
.Protect "123", Contents:=True, Scenarios:=True, AllowFiltering:=True
On Error GoTo 0
End With
With Workbooks("БД.xls"): .Close True: End With

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

С Ув. Staniiislav