Страницы: 1
RSS
Сводная данных относительно диапазона дат и доп. ячейки
 
Ребята, всем привет.
Преследуют опять нестандартные задачи. Прошу снова вашей помощи!
Прислали нам отчет. (файл прикрепил)
Есть листы с названиями от 1 до 52 (в примере только 2 листа с именами 9 и 10), это недели.

Раз в неделю сотрудник создает лист шаблон https://prntscr.com/10q4ywl в котором прописывается № недели и через ВПР сопоставляются даты.
сотрудник заполняет определенные поля https://prnt.sc/10q52os

Начальство захотело сделать отчет по всем неделям (листы от 1 до 52) прописывая диапазон дат и № заказа, на листе "Счет" (зеленый блок)
https://prnt.sc/10q4pdz и получить выборку согласно этих вводных (красный блок)

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

Подскажите оптимальный вариант в данном случае.

P.s. Правильно ли я понимаю, что нужно создать отдельный лист "типа база данных". И к ней пробовать применять фильтра по дате и т.д???
Как тогда выводить эти данные на отдельный лист?
Возможно можно применить умные таблицы или сводную?
Спасибо заранее.  
 
Антон,
Код
Sub mrshkei()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculateManual
Dim sh As Worksheet, i As Long, lr As Long, lr2 As Long, schet As Worksheet, r As Long, r2 As Long, n1 As String
Set schet = Worksheets("Счёт")
schet.Range("A7:F" & schet.Cells(Rows.Count, 1).End(xlUp).Row + 7).Clear
T = schet.Range("C2")
For i = schet.Range("A2") To schet.Range("B2") + 1 'цикл по заданным датам
    n1 = DatePart("ww", i, vbMonday) 'определяем номер недели/имя листа
    With Worksheets(n1)
    lr = .Cells(Rows.Count, 1).End(xlUp).Row
    For r = 2 To lr
        If .Cells(r, 1) = i Then
        For r2 = r + 1 To lr
            If .Cells(r2, 1) = T Then
                lr2 = schet.Cells(Rows.Count, 1).End(xlUp).Row + 1
                .Cells(r, 1).Copy
                schet.Cells(lr2, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
                schet.Cells(lr2, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
                .Range(.Cells(r2, 2), .Cells(r2, 6)).Copy Destination:=schet.Cells(lr2, 2)
            ElseIf .Cells(r2, 1) = "" Then
                GoTo NEXTI
            End If
        Next r2
        End If
    Next r
    End With
NEXTI:
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calc
Не бойтесь совершенства. Вам его не достичь.
 
Ещё вариант. Sbor2 с доработкой от Mershik, с выбором листов по номеру недели, в файле.
Код
Sub Sbor()
Dim LastRow As Long, j As Long, jj As Long, i As Long, a As Long, ii As Long
Application.ScreenUpdating = False
'Application.EnableEvents = False
Sheets("Счёт").Range("A7:F1000").Clear
a = 7
    For i = 1 To ThisWorkbook.Sheets.Count
    If Sheets(i).Name > 0 Then
        LastRow = Sheets(i).Cells(Rows.Count, 2).End(xlUp).Row
           With Sheets(i)
                For j = 2 To LastRow
                If .Cells(j, 1) >= Sheets("Счёт").Range("A2").Value And .Cells(j, 1) <= Sheets("Счёт").Range("B2").Value Then
                    For jj = j To j + 50
                        If .Cells(jj, 1) = "" Then Exit For
                    Next
                    For ii = j + 1 To jj - 1
                        If .Cells(ii, 1) = Sheets("Счёт").Range("C2").Value Then
                            .Cells(j, 1).Copy
                            Sheets("Счёт").Cells(a, 1).PasteSpecial Paste:=xlPasteFormats
                            Sheets("Счёт").Cells(a, 1).PasteSpecial Paste:=xlPasteValues
                            .Range(.Cells(ii, 2), .Cells(ii, 6)).Copy Sheets("Счёт").Cells(a, 2)
                            Sheets("Счёт").Range("A" & a & ":F" & a).Borders.LineStyle = xlContinuous
                            Sheets("Счёт").Range("A" & a & ":F" & a).Borders.Weight = xlThin
                            a = a + 1
                        End If
                    Next
                End If
                Next
            End With
    End If
    Next
Application.ScreenUpdating = True
'Application.EnableEvents = True
End Sub
 
Сейчас попробуем. Есть над чем подумать. Благодарю!
Страницы: 1
Наверх