Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос копирования строк из таблицы на другие листы по датам., Макрос копирования строк из таблицы на другие листы по датам.
 
#1
25.09.2017 14:49:43
Добрый день, подскажите как можно реализовать макрос, который будет из таблицы копировать строки на другие листы этой книги,строки за определённую дату на определённый лист. Допустим, чтобы строки таблицы за 01.09.2017 копировались в лист 01, за 02.09.2017 в лист 02 и.т.д
 
 
 
#2
25.09.2017 14:54:28
Цитата
как можно реализовать макрос
Ставите автофильтр по дате, копируете видимые строки на соответствующий лист
 
 
 
#3
25.09.2017 15:10:09
Необходимо чтобы по нажатию кнопки это автоматом делалось, на все листы.Без ручного копирования. Цель, чтобы из общей таблицы создавался отчёт по дням со строками на каждом листе по дате.
Изменено: desbane - 25.09.2017 15:12:09
 
 
 
#4
25.09.2017 15:38:16
Я вам и написал алгоритм решения вашей задачи.
1. Выделить из колонки с датами уникальные значения
2. цикл по этим уникальным значениям дат
3. для каждой даты применяете автофильтр и видимый диапазон копируете на соответствующий лист
Кнопочку на Лист1 и к ней привязать макрос.
 
 
 
#5
25.09.2017 16:10:44
"3. для каждой даты применяете автофильтр и видимый диапазон копируете на соответствующий лист ." - как это в макросе описать, не понимаю, если можете подробней объясните.Спасибо.
 
 
 
#6
25.09.2017 17:13:39
Предполагается, что в книге всегда есть соответствующий дате лист?
Или надо его создавать?
 
 
 
#7
25.09.2017 17:52:29
desbane, проверяйте.
Код
Sub copyToLists()
    Sheets("ЛИСТ1").Activate
    Dim copyRn As Range, dataWs As Worksheet, copySh As Worksheet
    Set copyRn = [A1:E25]
    Set dataWs = ActiveSheet
    dataWs.AutoFilterMode = False
    Dim uniqueDatesDic As Object
    Set uniqueDatesDic = CreateObject("Scripting.Dictionary")
    shNums = 1
    For i = 2 To copyRn.Columns(1).Cells.Count
        Set el = copyRn.Cells(i, 1)
        If Not uniqueDatesDic.Exists(el.Value) Then
            copyRn.AutoFilter Field:=1, Operator:=xlFilterValues, Criteria1:=el.Value
            Set copySh = SheetRequired(Format(shNums, "00"), True)
            copyRn.SpecialCells(xlCellTypeVisible).Copy Destination:=copySh.Range("A1")
            copySh.Cells.EntireColumn.AutoFit
            copySh.Move after:=Sheets(shNums)
            shNums = shNums + 1
            uniqueDatesDic.Add Key:=el.Value, Item:=shNums
            dataWs.AutoFilter.ShowAllData
        End If
    Next i
    dataWs.Activate
    dataWs.AutoFilterMode = False
End Sub


Function SheetRequired(SheetName As String, Optional needToClear As Boolean = False) As Object
    Dim curList As Object, SheetToReturn As Object
    Dim SheetNameEscaped As String
    Set curList = ActiveSheet
    SheetNameEscaped = SheetName
    If SheetExists(SheetNameEscaped) = True Then
        Sheets(SheetNameEscaped).Activate
    Else
        Sheets.Add
        ActiveSheet.name = SheetNameEscaped
    End If
    Set SheetToReturn = ActiveSheet
    
    If needToClear = True Then ActiveSheet.Cells.Delete
    curList.Select
    Set SheetRequired = SheetToReturn
End Function

Function SheetExists(name As String) As Boolean
    Dim SheetNameEscaped As String
    On Error GoTo ShNotFound
    If Sheets(name).name <> "" Then SheetExists = True
    Exit Function
ShNotFound:
    SheetExists = False
End Function
In GoTo we trust
 
 
 
#8
25.09.2017 19:15:28
Предполагается что всегда есть листы, 01,02.....31. Дни в таблицу будут добавляться. Чтот не работает макрос, копирует только шапку таблицы. Если дату изменить например на 10е число, то в лист 10 ничего не копируется. Мож у меня с excelем что не так.?
Изменено: desbane - 25.09.2017 19:17:35
 
 
 
#9
25.09.2017 19:45:03
desbane, нет, с Excel'ем, думаю, все нормально..
Попробуйте так:
Код
Sub copyToLists()
    Sheets("ЛИСТ1").Activate
    Dim copyRn As Range, dataWs As Worksheet, copySh As Worksheet, SheetName As String
    Set copyRn = Range([A1], [A1].End(xlDown).End(xlToRight))
    Set dataWs = ActiveSheet
    dataWs.AutoFilterMode = False
    Dim uniqueDatesDic As Object
    Set uniqueDatesDic = CreateObject("Scripting.Dictionary")
    For i = 2 To copyRn.Columns(1).Cells.Count
        Set el = copyRn.Cells(i, 1)
        If Not uniqueDatesDic.Exists(el.Value) Then
            copyRn.AutoFilter Field:=1, Operator:=xlFilterValues, Criteria1:=Array(2, el.Value)
            SheetName = Format(Day(el.Value), "00")
            uniqueDatesDic.Add Key:=el.Value, Item:=SheetName
            Set copySh = SheetRequired(SheetName, True)
            copyRn.SpecialCells(xlCellTypeVisible).Copy Destination:=copySh.Range("A1")
            copySh.Cells.EntireColumn.AutoFit
            copySh.Move after:=Sheets(Sheets.Count)
            dataWs.AutoFilter.ShowAllData
        End If
    Next i
    dataWs.Activate
    dataWs.AutoFilterMode = False
    dataWs.Move before:=Sheets(1)
End Sub
Изменено: tolstak - 25.09.2017 19:51:44
In GoTo we trust
 
 
 
#10
25.09.2017 19:56:36
Макрос в стандартный модуль, запускать при активном листе 1
Код
Sub Макрос1()
Dim FilteredRng As Range
Dim iDate As Date
Dim i As Long
Dim iLastRow As Long
Dim iDay As String
  With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
      iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
      Columns("H").ClearContents
    Range("A1:A" & iLastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("H1"), Unique:=True
    iLastRow = Cells(Rows.Count, "H").End(xlUp).Row
      For i = 2 To iLastRow
        iDate = Cells(i, "H")
        iDay = CStr(Day(iDate))
          If Len(iDay) = 1 Then iDay = "0" & iDay
            If ActiveSheet.AutoFilterMode = False Then
                Range("A1:E1").AutoFilter
            Else
                If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
            End If
              Range("A1").AutoFilter Field:=1, Criteria1:=iDate
            With ActiveSheet.AutoFilter.Range
                Worksheets(iDay).Cells.Clear
                .Resize(.Rows.Count, 5).SpecialCells(xlCellTypeVisible).Copy Worksheets(iDay).Range("A1")
                Worksheets(iDay).Columns("A:E").AutoFit
            End With
            ActiveSheet.ShowAllData
      Next
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub
 
 
 
#11
26.09.2017 15:06:26
Всем большое спасибо. Всё работает, с моей проблемой помогло)
 
 
 
Страницы: 1
Читают тему
Наверх