Ребята, всем привет. Преследуют опять нестандартные задачи. Прошу снова вашей помощи! Прислали нам отчет. (файл прикрепил) Есть листы с названиями от 1 до 52 (в примере только 2 листа с именами 9 и 10), это недели.
Начальство захотело сделать отчет по всем неделям (листы от 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