Коприрование диапазонов по датам

[Робин]

Добрый день
Ребята может в отдельной теме заметите. Мне нужно создавать сводную таблицу с даными за год. Помесячные таблицы динамичны. Постоянно меняют свою длину. при этом шапка таблицы постоянна. То есть свои координаты не меняет.
У самого такие сложные макросы не получается.
Заранее благодарю за помощь

[staniiislav]

пробуйте:

[Робин]

Добрый день
staniiislav макрос работает, спасибо.
Но вы немножко не правильно поняли вопрос. Мне нужно копировать не все листы одновременно, а ежемесячно добавлять новый лист за следующий месяц у свод.
Причем так, чтобы нельзя было скопировать один и тот же месяц дважды, без согласия юзера(Да или Нет.
Например, если я хочу скопировать отредактированые даные, за какой то, ранее скопированый месяц, тогда нажимаю кнопку Да. А если случайно нажал на кнопку копирования - тогда Нет.

[staniiislav]

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

Добрый день
Но вы немножко не правильно поняли вопрос

Возможно Вы немножко не правильно описали свою задачу?

Пользуйтесь...

[staniiislav]

увидел небольшую ошибку, немного позже переделаю

[Робин]

Добрый день
staniiislav. Для начала благодарен вам за то что заморочились моей не простой проблемой!
А тестирование примера показало следующее

1.Копирование осуществляю при активном листе Свод, то есть, курсор находится на этом листе. Запускаю макрос, копируется только последний лист за сентябрь. При повторном нажатии кнопки копирования макрос срабатывет правильно.

2.Копирование осуществляю, находясь на любом другом листе.
Например, на листе 08.2012. Запускаю макрос, копирование происходит на оборот, с листа Свод на лист 08.2012.

А нужно, к примеру, находясь на активном листе 08.2012 , копировать его на лист Свод. И так далее. По всем месяцам года. То есть, кнопочка копирования, должна находться именно на этих листах. А сами помесячные листы, будут создаваться тоже макросом, путем копирования предыдущего месяца, вместе со всеми форматами и кнопками. И это, я вроди знаю, как сделать. В крайнем случае, воспользуюсь макрорекодером.
Вот такая задумка.
Еще раз спасибо вам за дружескую помощь.

[staniiislav]

это мое последнее изменение

Sub Свод_по_месяцам()
Dim acRow As Long
Dim svRow As Long
Dim f_1 As Long
Dim f_2 As Long
Dim acWsh As Worksheet
Dim svWsh As Worksheet
Dim s As Range
Dim p, f
Dim msg As Integer

Application.ScreenUpdating = False
Application.EnableEvents = False

    Set acWsh = ThisWorkbook.ActiveSheet
    Set svWsh = ThisWorkbook.Sheets("Свод")
    msg = MsgBox(Title:="Подтверждение", prompt:="Скопировать данные с листа [" & acWsh.Name & "] в свод", _
                Buttons:=vbYesNo + vbQuestion)
    
    If msg = vbNo Then Application.EnableEvents = True: Application.ScreenUpdating = True: Exit Sub
    
        acRow = acWsh.Cells(Rows.Count, 1).End(xlUp).Row
        svRow = svWsh.Cells(Rows.Count, 1).End(xlUp).Row
        
    
        Set s = svWsh.Range("M6:M" & svRow)
        Set p = s.Find(what:=acWsh.Name, LookAt:=xlWhole)
            If Not p Is Nothing Then
                If MsgBox(Title:="Предупреждение", prompt:="Найдено совпадение по листу [" & acWsh.Name & "], заменить?", _
                            Buttons:=vbYesNo + vbExclamation) = vbYes Then
                    Set f = s.Find(what:=acWsh.Name, LookAt:=xlWhole, SearchDirection:=xlPrevious)
                        If Not f Is Nothing Then
                            f_1 = acRow - 6
                            f_2 = f.Row - p.Row + 1
                            If f_1 > f_2 Then
                                svWsh.Rows(f.Row + 1 & ":" & f.Row + f_1 - f_2).Insert _
                                Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                            ElseIf f_1 < f_2 Then
                                svWsh.Rows(f.Row + 1 + f_1 - f_2 & ":" & f.Row).Delete Shift:=xlUp
                            End If
                        End If
                            acWsh.Range("A7:L" & acRow).Copy
                            svWsh.Range("A" & p.Row).PasteSpecial Paste:=xlPasteValues
                            svWsh.Range("A" & p.Row).PasteSpecial Paste:=xlPasteFormats
                            svWsh.Range("M" & p.Row & ":" & "M" & p.Row + acRow - 7).NumberFormat = "@"
                            svWsh.Range("M" & p.Row & ":" & "M" & p.Row + acRow - 7) = Format(acWsh.Name, "mm.yyyy")
                    End If
                Else
                    acWsh.Range("A7:L" & acRow).Copy
                    svWsh.Range("A" & svRow + 1).PasteSpecial Paste:=xlPasteValues
                    svWsh.Range("A" & svRow + 1).PasteSpecial Paste:=xlPasteFormats
                    svWsh.Range("M" & svRow + 1 & ":" & "M" & svWsh.Cells(Rows.Count, 1).End(xlUp).Row).NumberFormat = "@"
                    svWsh.Range("M" & svRow + 1 & ":" & "M" & svWsh.Cells(Rows.Count, 1).End(xlUp).Row) = Format(acWsh.Name, "mm.yyyy")
            End If
                
            
Application.CutCopyMode = False
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

[Робин]

Попробовал, вроди работает как надо.Спасибо!
Буду вникать в макрос что откуда берется , куда и как вставляется. Чтоб понять его суть и научиться писать такой макрос и ему подобные - своими руками.
Если вы позволите, задать некоторые вопросы, по содержанию макроса, которые могут возникнуть в ходе изучения, то задам.
Еще раз благодарю вас за помощь.