Option Explicit
Sub Лист_в_умную()
CloseEmptyWb
Dim sh As Worksheet
If Cells(1, 1).Value = "<DATE>" Then
Set sh = ActiveSheet
Else
Dim si As Worksheet
For Each si In ActiveWorkbook.Worksheets
If si.Cells(1, 1).Value = "<DATE>" Then
Set sh = si
GoTo ExitFor
End If
Next
If sh Is Nothing Then
Dim wb As Workbook
For Each wb In Application.Workbooks
For Each si In wb.Worksheets
If si.Cells(1, 1).Value = "<DATE>" Then
Set sh = si
GoTo ExitFor
End If
Next
Next
End If
End If
ExitFor:
MakeListObjectFromPivotSheet sh
End Sub
Sub Сводную_в_умную()
CloseEmptyWb
Dim pt As PivotTable
On Error Resume Next
Set pt = ActiveSheet.PivotTables(1)
If pt Is Nothing Then
Dim wb As Workbook
For Each wb In Application.Workbooks
wb.Activate
Set pt = ActiveSheet.PivotTables(1)
If Not pt Is Nothing Then Exit For
Next
End If
On Error GoTo 0
MakeListObjectFromPivotTable pt
End Sub
Private Sub MakeListObjectFromPivotSheet(sh As Worksheet)
Dim arr As Variant
arr = GetArrFromSheet(sh)
PrintArr arr, Workbooks.Add(1).Sheets(1).Cells(1, 1)
End Sub
Private Sub MakeListObjectFromPivotTable(pt As PivotTable)
Dim arr As Variant
arr = GetArr(pt)
PrintArr arr, Workbooks.Add(1).Sheets(1).Cells(1, 1)
End Sub
Private Function GetArrFromSheet(sh As Worksheet) As Variant
Dim arr As Variant
arr = Intersect(sh.Columns("A:F"), sh.UsedRange).Value
Dim dic As Object
Set dic = GetDic(arr)
If dic.Count = 0 Then Exit Function
Dim yd As Long, yb As Long, sm As Long, yt As Long, xs As Long, xf As Long
Dim brr As Variant, frr As Variant
brr = dic.Items()(0).Items()(0).Items()(0)
ReDim arr(1 To dic.Count + 1, 1 To 1 + 2 * (3 + UBound(brr) + 1))
brr = Split("Дата,Сессия,Начало,Окончание,Открытие,Максимум,Минимум,Закрытие,Сессия 2,Начало 3,Окончание 4,Открытие 5,Максимум 6,Минимум 7,Закрытие 8", ",")
For xs = 1 To UBound(brr)
arr(1, xs) = brr(xs - 1)
Next
brr = Empty
Dim bic As Object, cic As Object
For yd = 0 To dic.Count - 1
Set bic = dic.Items()(yd)
For sm = 0 To bic.Count - 1
Set cic = bic.Items()(sm)
frr = cic.Items()(0)
For yt = 1 To cic.Count - 1
brr = cic.Items()(yt)
If frr(1) < brr(1) Then frr(1) = brr(1)
If frr(2) > brr(2) Then frr(2) = brr(2)
frr(3) = brr(3)
Next
If bic.Keys()(sm) = "Дневная" Then
xs = 2
ElseIf bic.Keys()(sm) = "Вечерняя" Then
xs = 2 + 3 + UBound(frr) + 1
End If
For xf = 0 To UBound(frr)
arr(2 + yd, xs + xf + 3) = frr(xf)
Next
arr(2 + yd, xs + 1) = bic.Items()(sm).Keys()(0)
arr(2 + yd, xs + 2) = bic.Items()(sm).Keys()(cic.Count - 1)
arr(2 + yd, xs) = bic.Keys()(sm)
Next
arr(2 + yd, 1) = dic.Keys()(yd)
Next
GetArrFromSheet = arr
End Function
Private Function GetDic(arr As Variant) As Object
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim ya As Long, ss As String, dt As Date, tt As Date
For ya = 2 To UBound(arr, 1)
If IsNumeric(arr(ya, 1)) Then
If IsNumeric(arr(ya, 2)) Then
dt = 0
tt = 0
On Error Resume Next
ss = Left(arr(ya, 1), 4) & "." & Mid(arr(ya, 1), 5, 2) & "." & Mid(arr(ya, 1), 7, 2)
dt = DateValue(ss)
ss = Left(arr(ya, 2), Len(arr(ya, 2)) - 4) & ":" & Mid(arr(ya, 2), Len(arr(ya, 2)) - 3, 2) & ":" & Right(arr(ya, 2), 2)
tt = TimeValue(ss)
On Error GoTo 0
If dt > 0 And tt > 0 Then
If arr(ya, 2) >= 60000 And arr(ya, 2) < 190000 Then
ss = "Дневная"
Else
ss = "Вечерняя"
End If
If Not dic.Exists(dt) Then
Set dic(dt) = CreateObject("Scripting.Dictionary")
End If
If Not dic(dt).Exists(ss) Then
Set dic(dt)(ss) = CreateObject("Scripting.Dictionary")
End If
dic(dt)(ss)(tt) = Array(arr(ya, 3), arr(ya, 4), arr(ya, 5), arr(ya, 6))
End If
End If
End If
Next
Set GetDic = dic
End Function
Private Function GetArr(pt As PivotTable) As Variant
Dim arr As Variant, brr As Variant, ya As Long, yb As Long, xa As Long, xb As Long
arr = pt.TableRange1.Value
ReDim brr(1 To UBound(arr, 1), 1 To 2 * (UBound(arr, 2) - 1) + 1)
Dim hrr As Variant
hrr = Split("Дата Сессия Начало Окончание Открытие Максимум Минимум Закрытие Сессия2 Начало3 Окончание4 Открытие5 Максимум6 Минимум7 Закрытие8", " ")
For xb = 1 To UBound(brr, 2)
brr(1, xb) = hrr(xb - 1)
Next
yb = 1
For ya = 2 To UBound(arr, 1)
If Not IsEmpty(arr(ya, 1)) Then
yb = yb + 1
xb = 1
brr(yb, xb) = arr(ya, 1)
For xa = 2 To UBound(arr, 2)
xb = xb + 1
brr(yb, xb) = arr(ya, xa)
Next
If ya < UBound(arr, 1) Then
If IsEmpty(arr(ya + 1, 1)) Then
For xa = 2 To UBound(arr, 2)
xb = xb + 1
brr(yb, xb) = arr(ya + 1, xa)
Next
End If
End If
End If
Next
brr = ResizeArray(brr, yb)
GetArr = brr
End Function
Private Function ResizeArray(arr, yNew As Long) As Variant
Dim brr As Variant
ReDim brr(1 To yNew, 1 To UBound(arr, 2))
Dim yb As Long, xb As Long
For yb = 1 To UBound(brr, 1)
For xb = 1 To UBound(brr, 2)
brr(yb, xb) = arr(yb, xb)
Next
Next
ResizeArray = brr
End Function
Private Sub PrintArr(arr As Variant, rTarg As Range)
Set rTarg = rTarg.Resize(UBound(arr, 1), UBound(arr, 2))
rTarg.Value = arr
Dim xx As Long, dx As Long
dx = (rTarg.Columns.Count - 3) / 2 + 1
For xx = 3 To 4
rTarg.Columns(xx).NumberFormat = "hh:mm:ss;@"
rTarg.Columns(xx + dx).NumberFormat = "hh:mm:ss;@"
Next
For xx = 5 To (rTarg.Columns.Count - 1) / 2 + 1
rTarg.Columns(xx).NumberFormat = "#,##0"
rTarg.Columns(xx + dx).NumberFormat = "#,##0"
Next
Dim sh As Worksheet
Set sh = rTarg.Parent
With sh.ListObjects.Add(xlSrcRange, rTarg, , xlYes)
.Name = "Таблица1"
.TableStyle = "TableStyleMedium2"
End With
Dim tb As ListObject
Set tb = sh.ListObjects(1)
rTarg.HorizontalAlignment = xlCenter
rTarg.EntireColumn.AutoFit
' Workbooks("Результат.xlsx").Sheets(1).UsedRange.Copy rTarg.Cells(rTarg.Rows.Count + 2, 1)
sh.Parent.Saved = True
End Sub
Private Sub CloseEmptyWb()
Dim wb As Workbook
For Each wb In Application.Workbooks
If wb.Path = "" Then wb.Close False
Next
End Sub
|
