Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Макрос копирования таблицы на каждый день недели
 
Доброго времени, планетяне!!!

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

Есть таблица, которая будет обновляться ежедневно с большим количеством записей (более 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
Изменено: allovar - 2 Сен 2018 22:09:12
 
Попробуйте следующий макрос вместо своего.
Код
' Фильтрует таблицу и переносит видимые ячейки в лист с именем дня
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
Владимир
 
sokol92, огромнейшее Вам спасибо!!!! То, что доктор прописал )))
Еще раз благодарю
 
Успехов и радости от общения с Excel!
Владимир
Страницы: 1
Читают тему (гостей: 1)
Наверх