Макрос копирования таблицы на каждый день недели

Пользователь

Сообщений: 19 Регистрация: 31.10.2017

01.09.2018 22:52:36

Доброго времени, планетяне!!!

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

Есть таблица, которая будет обновляться ежедневно с большим количеством записей (более 700 тыс). После фильтрации (устанавливается вчерашняя дата), и нажатия кнопки, данные за вчерашний день должны будут скопированы на другой лист с присвоением этому листу дня недели (в соответствии со вчерашней датой). Например, как показано в примере: данные за 25/06/18 - Понедельник, должны быть скопированы на лист с именем Mon. Как только заполнились все 7 дней недели, то листы обнуляются и в листе Mon будут уже данные за 02/07/18 и т.д.

Единственный макрос, что я записал, делает копию на другой лист бесконечное количество раз и без имени листа

Код

Sub CopyTable()
    Sheets("Statistics").Range("A8:C500000").Copy 'Copy data in active table
    Sheets.Add After:=Worksheets(Worksheets.Count)
    Range("A1").Select 'Selecting right range
    Selection.PasteSpecial Paste:=xlPasteColumnWidths
    ActiveSheet.Paste 'Pasting in right destination
    Application.CutCopyMode = False
End Sub

Прикрепленные файлы

Statistics_ver.02.xlsm (161.09 КБ)

Изменено: allovar - 02.09.2018 22:09:12

sokol92

Пользователь

Сообщений: 4661 Регистрация: 10.09.2017

02.09.2018 20:25:07

Попробуйте следующий макрос вместо своего.

Код

' Фильтрует таблицу и переносит видимые ячейки в лист с именем дня
Sub CopyTable()
  Dim tbl As ListObject, shName As String, dt As Date, nCols As Long
  Set tbl = ActiveSheet.ListObjects(1)
  nCols = tbl.Range.Columns.Count
  dt = Range("B1") - 1  ' дата для установки автофильтра (предыдущая по отношению к дате из ячейки B1)
  
  tbl.Range.AutoFilter 3, , xlFilterValues, Array(2, Format(dt, "mm\/dd\/yyyy"))
  If tbl.Range.SpecialCells(xlCellTypeVisible).Cells.Count <= nCols Then
    MsgBox "Данных за дату " & dt & " не найдено", vbExclamation
    Exit Sub
  End If
  shName = Choose(Weekday(dt, vbMonday), "Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun")
  With Worksheets(shName)
    .Cells.Delete
    tbl.Range.SpecialCells(xlCellTypeVisible).Copy .Range("A1")
    .Range(.Cells(1, 1), .Cells(1, nCols)).EntireColumn.AutoFit  ' выравниваем столбцы
    MsgBox "Данные скопированы на лист " & .Name
  End With
End Sub

Владимир

allovar Пользователь Сообщений: 19 Регистрация: 31.10.2017	#3 03.09.2018 09:46:06 sokol92, огромнейшее Вам спасибо!!!! То, что доктор прописал ))) Еще раз благодарю

sokol92 Пользователь Сообщений: 4661 Регистрация: 10.09.2017	#4 03.09.2018 12:21:09 Успехов и радости от общения с Excel! Владимир