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

Здравствуйте Уважаемые Форумчане!!!

Помогите с макросом, что бы решить задачу…

У нас есть Данные на Листе1 (не календарные, а рабочие). Нужно их разделить с Периодом – Месяц, показал на Листе2. Если еще сразу при разделении получится добавить Столбец – Нумерации, показал на Листе3, будет просто здорово.

 
Добавьте в книгу новый лист. Оставаясь на нём, выполните этот макрос:
Код
Sub Macro1()
Dim i As Long, LastRow As Long, Uniq As New Collection
Dim iMonth, Rng As Range, x As Long, Arr(), Arr2, iCol As Long
    With Sheets("Лист1")
        LastRow = .Cells(Rows.Count, 2).End(xlUp).Row
        Arr = Range(.Cells(3, 2), .Cells(LastRow, 7)).Value
        Set Rng = .Range("A2:F2")
    End With
    Rng(1) = "No"
    On Error Resume Next
    For i = 1 To UBound(Arr)
        Arr(i, 6) = Month(Arr(i, 1))
        Uniq.Add Arr(i, 6), CStr(Arr(i, 6))
    Next
    iCol = 2
    Application.ScreenUpdating = False
    For Each iMonth In Uniq
        ReDim Arr2(1 To UBound(Arr), 1 To 6)
        Rng.Copy Cells(10, iCol)
        For i = 1 To UBound(Arr)
            If Arr(i, 6) = iMonth Then
                x = x + 1
                Arr2(x, 1) = x - 1
                Arr2(x, 2) = Arr(i, 1)
                Arr2(x, 3) = Arr(i, 2)
                Arr2(x, 4) = Arr(i, 3)
                Arr2(x, 5) = Arr(i, 4)
                Arr2(x, 6) = Arr(i, 5)
                
            End If
        Next
        Cells(11, iCol).Resize(x, 6).Value = Arr2
        Columns(iCol + 1).AutoFit
        iCol = iCol + 7
        x = 0
    Next
    Application.ScreenUpdating = True
End Sub

 
Юрий М, кажется в 6 строке не хватает точки перед Range
Не бойтесь совершенства. Вам его не достичь.
 
Цитата
Mershik написал:
в 6 строке не хватает точки перед Range
Если бы код был в модуле листа, точка обязательно нужна. А из стандартного можно и без неё. Главное - перед Cells. Но если её добавить и перед Range - не помешает :)
 
Юрий М - Большое Вам Спасибо за Помощь!!! Почти Идеально!!!

На Листе2 результат работы Макроса, на Листе3 так как –хотелось бы.
Удалил 9 – Строку, в Вашем Коде (Rng(1) = "No"), просто сразу прописал на Листе1 в Ячейке А2 - № и сделал Внешние Границы.

Еще бы отформатировать полученные таблицы, было бы здорово.
1. Выровнять все Столбцы по Середине и по Центру.
2. Отформатировать столбец - Data/Time - ДД.ММ.ГГГГ чч:мм.
3. Отформатировать столбцы – Open, High, Low, Close – Числовой – Число знаков – 5.

Еще раз Спасибо за Помощь!!!
 
Запишите рекордером форматирование столбцов и добавьте код в мой макрос.
Ещё вариант: отформатируйте один раз вручную столбцы на итоговом листе - макрос ведь вставляет только значения.
 
Добавил предварительную очистку диапазонов (данные и границы ячеек). Добавил создание границ диапазонов.
Код
Sub Macro1()
Dim i As Long, LastRow As Long, Uniq As New Collection
Dim iMonth, Rng As Range, x As Long, Arr(), Arr2, iCol As Long
    With Sheets("Лист1")
        LastRow = .Cells(Rows.Count, 2).End(xlUp).Row
        Arr = Range(.Cells(3, 2), .Cells(LastRow, 7)).Value
        Set Rng = .Range("A2:F2")
    End With
    Application.ScreenUpdating = False
    LastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lastcolumn = Cells(10, Columns.Count).End(xlToLeft).Column
    With Range(Cells(10, 2), Cells(LastRow, lastcolumn))
        .ClearContents
        .Borders.LineStyle = False
    End With
    On Error Resume Next
    For i = 1 To UBound(Arr)
        Arr(i, 6) = Month(Arr(i, 1))
        Uniq.Add Arr(i, 6), CStr(Arr(i, 6))
    Next
    iCol = 2
    For Each iMonth In Uniq
        ReDim Arr2(1 To UBound(Arr), 1 To 6)
        Rng.Copy Cells(10, iCol)
        For i = 1 To UBound(Arr)
            If Arr(i, 6) = iMonth Then
                x = x + 1
                Arr2(x, 1) = x - 1
                Arr2(x, 2) = Arr(i, 1)
                Arr2(x, 3) = Arr(i, 2)
                Arr2(x, 4) = Arr(i, 3)
                Arr2(x, 5) = Arr(i, 4)
                Arr2(x, 6) = Arr(i, 5)
            End If
        Next
        Cells(11, iCol).Resize(x, 6).Value = Arr2
        Range(Cells(10, iCol), Cells(x + 10, iCol + 5)).Borders.LineStyle = True
        Columns(iCol + 1).AutoFit
        iCol = iCol + 7
        x = 0
    Next
    Application.ScreenUpdating = True
End Sub
Форматирование зайте сами изначально.
Страницы: 1
Читают тему (гостей: 1)
Наверх