Разнести данные

[tgm]

Разнести данные по листам.Помогите пожалуйста решить.

[doober]

Смотрите вложение

[tgm]

doober! Спасибо большое,то что нужно!

[tgm]

Добрый вечер! Хочу применить макрос немножечко для других целей. В принципе смысл остался тот-же,только данный макрос переносит данные в пределах месяца (т.е если я ставлю текущую дату 01.01.2010 он вставляет данные под дату 01.01.2010,но если текущую дату ставлю 01.02.2010 -то она всеравно ставится под дату 01.01.2010 ),а хотелось-бы продлить дипазон дней (в оригинальном файле диапазон будет на несколько лет). Помогите пожалуйста.

[tgm]

Нереально?

[Hugo121]

Простой вариант (особо ничего не переделывая) - вводим M_month, делаем график по 31 день в месяце (лишние столбцы можно скрыть), данные заносим строкой

             Sheets("Показатель1").Cells(rng.Row, D_dey + 3 + 31 * (M_month - 1)) = Sheets("Лист1").Cells(n + 6, 6)

Итого:

Sub Pokas()
    Dim rng As Range
    Dim rn
    Dim D_day As Integer
    D_dey = Day(Sheets("Лист1").Range("C1"))
    M_month = Month(Sheets("Лист1").Range("C1"))
    rn = Sheets("Лист1").Range("B7:b65500").SpecialCells(xlCellTypeConstants)

    For n = 1 To UBound(rn)
        Set rng = Sheets("Показатель1").Range("B:B").Find(rn(n, 1))
        If Not rng Is Nothing Then

            Sheets("Показатель1").Cells(rng.Row, D_dey + 3 + 31 * (M_month - 1)) = Sheets("Лист1").Cells(n + 6, 6)

        End If
    Next
End Sub

[tgm]

Hugo121! Спасибо большое. На данном этапе все работает,осталась 1 проблема. Дело в том что у меня в оригинале диапазон дат больше (пример как-то хитро сохранился,что осталась только половина столбцов),т.е идут данные за несколько лет. 2010 разносит без проблем,но когда выбираю следующий 2011 год,то данные все равно вставляет в 2010...

[doober]

Минимальная дата 01.01.2010
А там на сколько столбцов хватит

Sub Pokas()
Dim rng As Range
Dim rn
Dim D_day As Double
D_day = Sheets("Лист11").Range("C1")
 rn = Sheets("Лист1").Range("B7:b65500").SpecialCells(xlCellTypeConstants)
 For n = 1 To UBound(rn)
 Set rng = Sheets("Показатель1").Range("B:B").Find(rn(n, 1))
 If Not rng Is Nothing Then
 Sheets("ÏПоказатель1").Cells(rng.Row, D_day - 40175) = Sheets("Лист1").Cells(n + 6, 6)
 End If
 Next
 End Sub

[tgm]

doober,все работает! Спасибо огромное!