Макрос для сортировки дат по строкам

[Aleksey]

Добрый день. Подскажите пожалуйста. Как написать такой макрос, чтобы он сортировал даты в таблице по порядку (от старых к новым), затем добавлял разделители по месяцам. Заранее благодарен.

[Kuzmich]

Код Выделить Развернуть

Sub iSort()
Dim Itog As Worksheet
Dim iLastRow As Long
Dim i As Long
  Set Itog = ThisWorkbook.Worksheets("Èòîã")
  iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    With Itog
      .Cells.Clear
      Range("A1:J" & iLastRow).Copy .Cells(1, 1)
      .Range("A4:J" & iLastRow).Sort Key1:=.Range("F4"), Order1:=xlAscending, Header:=xlYes
        iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        For i = iLastRow To 6 Step -1
        If IsDate(.Cells(i - 1, "F")) Then
          If Month(.Cells(i, "F")) <> Month(.Cells(i - 1, "F")) Then
            .Rows(i).Insert
            .Range("A" & i & ":J" & i).Merge
            .Range("A" & i).HorizontalAlignment = xlCenter
            .Range("A" & i) = Format(.Cells(i + 1, "F"), "MMMM")
          End If
        End If
        Next
            .Range("A5").EntireRow.Insert
            .Range("A5 :J5").Merge
            .Range("A5 :J5").HorizontalAlignment = xlCenter
            .Range("A5 :J5") = Format(.Cells(6, "F"), "MMMM")
    End With
End Sub

[Aleksey]

Спасибо Вам огромное. Можно Вас ещё спросить? Как сделать нумерацию строк по порядку исключая месяцы и какой дописать код, чтобы копировалось содержание которое перед таблицей и поля для подписей после таблицы? Файл-пример прилагаю.

[Kuzmich]

Код Выделить Развернуть

Sub iSort_()
Dim Itog As Worksheet
Dim iLastRow As Long
Dim i As Long
Dim sh As Shape
  Set Itog = ThisWorkbook.Worksheets("Итог")
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    With Itog
      .Cells.Clear
      For Each sh In .Shapes
        If sh.Name Like "*" Then
          sh.Delete
        End If
      Next
      Range("A1:J" & iLastRow).Copy .Cells(1, 1)
        iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
      .Range("A22:J" & iLastRow).Sort Key1:=.Range("F4"), Order1:=xlAscending, Header:=xlYes
'        iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
       
        .Range("A23") = 1
        .Range("A23").DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
        Step:=1, Stop:=iLastRow - 22, Trend:=False

       
        For i = iLastRow To 23 Step -1
        If IsDate(.Cells(i - 1, "F")) Then
          If Month(.Cells(i, "F")) <> Month(.Cells(i - 1, "F")) Then
            .Rows(i).Insert
            .Range("A" & i & ":J" & i).Merge
            .Range("A" & i).HorizontalAlignment = xlCenter
            .Range("A" & i) = Format(.Cells(i + 1, "F"), "MMMM")
          End If
        End If
        Next
            .Range("A23").EntireRow.Insert
            .Range("A23 :J23").Merge
            .Range("A23 :J23").HorizontalAlignment = xlCenter
            .Range("A23 :J23") = Format(.Cells(24, "F"), "MMMM")
    End With
End Sub

[Дмитрий Щербаков(The_Prist)]

Kuzmich - Коды оформляйте тегами Code(Код). п.п. 4.25 Правил форума.
Я не могу постоянно делать это за Вас

[Kuzmich]

Дмитрий!
Я потыкал мышкой по иконкам, но так как подсказки не появляются, то оставил как есть.

[Дмитрий Щербаков(The_Prist)]

подсказки не появляются

у меня появляются. Наводите на иконку, ждете секунду - всплывает подсказка.

[Aleksey]

Kuzmich, можно Вас пожалуйста попросить, дополнить в макрос код, чтобы содержимое в таблице из страницы «ФИЛЬТР» копировалось на страницу «Итог» не как ссылки, а как просто значения? т.к. макрос с этой формулой не работает. Файл-пример прилагаю.

[Дмитрий Щербаков(The_Prist)]

Попробуйте заменить эту строку:

Код Выделить Развернуть

Range("A1:J" & iLastRow).Copy .Cells(1, 1)на такие:

Код Выделить Развернуть

Range("A1:J" & iLastRow).Copy
.Cells(1, 1).PasteSpecial xlPasteValues
.Cells(1, 1).PasteSpecial xlPasteFormats
Application.CutCopyMode = false

[Kuzmich]

Aleksey
Не очень понял о каких ссылках идет речь?
И почему пример без макроса?

[Aleksey]

The_Prist всё работает, только линии не переносятся на страницу «Итог»

[Дмитрий Щербаков(The_Prist)]

линии не переносятся

сделали бы на листе ФИЛЬТР эти линии через границы ячеек, а не фигурами - тогда и лишних телодвижений не потребовалось бы.
Ну а без этого - можно накрутить лишнего(что не всегда хорошо):

Код Выделить Развернуть

Sub iSort_()
Dim Itog As Worksheet, wsFilter As Worksheet
Dim iLastRow As Long
Dim i As Long
Dim sh As Shape
  Set wsFilter = ActiveSheet
  Set Itog = ThisWorkbook.Worksheets("Итог")
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    With Itog
      .Cells.Clear
      .DrawingObjects.Delete
      wsFilter.Range("A1:J" & iLastRow + 1).Copy .Cells(1, 1)
      .Cells.UnMerge
      .Cells.Value = Empty
      wsFilter.Range("A1:J" & iLastRow + 1).Copy
      .Cells(1, 1).PasteSpecial xlPasteValues
      .Cells(1, 1).PasteSpecial xlPasteFormats
      Application.CutCopyMode = False
        iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
      .Range("A22:J" & iLastRow).Sort Key1:=.Range("F4"), Order1:=xlAscending, Header:=xlYes
'        iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
       
        .Range("A23") = 1
        .Range("A23").DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
        Step:=1, Stop:=iLastRow - 22, Trend:=False

       
        For i = iLastRow To 23 Step -1
        If IsDate(.Cells(i - 1, "F")) Then
          If Month(.Cells(i, "F")) <> Month(.Cells(i - 1, "F")) Then
            .Rows(i).Insert
            .Range("A" & i & ":J" & i).Merge
            .Range("A" & i).HorizontalAlignment = xlCenter
            .Range("A" & i) = Format(.Cells(i + 1, "F"), "MMMM")
          End If
        End If
        Next
            .Range("A23").EntireRow.Insert
            .Range("A23 :J23").Merge
            .Range("A23 :J23").HorizontalAlignment = xlCenter
            .Range("A23 :J23") = Format(.Cells(24, "F"), "MMMM")
    End With
End Subда, заменил цикл по фигурам на одну строку удаления - цикл лишний, от слова совсем, да еще с Like на любую строку.