Option Explicit
'Версия 5.
Sub Main()
Dim arr As Variant
arr = GetArr()
OutArr arr
End Sub
Sub OutArr(arr As Variant)
With Sheets("СЗ ")
.Select
If UBound(arr, 1) > 1 Then
Dim rSeelction As Range
Set rSeelction = Selection
.Rows(13).Copy
.Cells(14, 1).Resize(UBound(arr, 1) - 1, 1).EntireRow.Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
Application.CutCopyMode = False
rSeelction.Select
End If
.Range("A13").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
Dim rRow As Range
For Each rRow In .Range("A13").Resize(UBound(arr, 1), UBound(arr, 2)).Rows
rRow.RowHeight = 13 * (Len(rRow.Range("G1").Value) - Len(Replace(rRow.Range("G1").Value, vbCr, "")) + 1)
Next
Do
If Not IsNumeric(.Cells(13 + UBound(arr, 1), 1)) Then Exit Do
.Rows(13 + UBound(arr, 1)).Delete Shift:=xlUp
DoEvents
Loop
End With
End Sub
Function GetArr() As Variant
Dim sh As Worksheet
Set sh = Sheets("СВОДКА РЭС-7")
With sh
.Select 'Проверка выполняется по выделенным ячейкам
Dim y As Long
y = .Cells(.Rows.Count, 2).End(xlUp).Row
Dim arr As Variant
arr = .Range(.Cells(1, 1), .Cells(y, "AJ"))
End With
Dim x As Integer
Dim e As Integer
Dim crr As Variant
Dim brr As Variant
'ReDim brr(0 To 0)
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim yM As Long
yM = 13
For y = 15 To UBound(arr, 1)
'Месяц
If arr(y, 2) = "Ф.И.О." Then yM = y
For x = 6 To UBound(arr, 2)
Select Case arr(y, x)
Case " "
If Not Intersect(sh.Cells(y, x), Selection) Is Nothing Then
e = x
Do
Select Case arr(y, e)
Case " "
e = e + 1
Case Else
e = e - 1
Exit Do
End Select
Loop
If Not dic.Exists(arr(y, 2)) Then
' crr = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
Set dic.Item(arr(y, 2)) = CreateObject("Scripting.Dictionary")
Else
' crr = dic.Item(arr(y, 2))
' crr(UBound(crr)) = arr(yM + 1, e) & " " & arr(yM, 6)
End If
crr = Array(arr(y, 5), arr(y, 2), DateValue(arr(yM + 1, x) & " " & arr(yM, 6)), DateValue(arr(yM + 1, e) & " " & arr(yM, 6)))
dic.Item(arr(y, 2)).Item(dic.Item(arr(y, 2)).Count) = crr
' ReDim Preserve brr(0 To UBound(brr) + 1)
' brr(UBound(brr)) = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
x = e
End If
DoEvents
End Select
Next
Next
Dim orr As Variant
brr = dic.Items()
If dic.Count < 1 Then
ReDim orr(1 To 1, 1 To 7)
Else
ReDim orr(1 To UBound(brr) + 1, 1 To 7)
Dim u As Long
Dim v As Variant
Dim dit As Object
For y = 0 To UBound(brr)
u = u + 1
orr(u, 1) = y + 1
orr(u, 2) = brr(y).Items()(0)(0)
orr(u, 3) = brr(y).Items()(0)(1)
Set dit = CreateObject("Scripting.Dictionary")
For Each v In brr(y).Items()
' orr(y + 1, 3) = brr(y)(1)
' orr(y + 1, 4) = Empty
' orr(y + 1, 5) = Empty
' orr(y + 1, 6) = Empty
dit.Item(Replace(Format(v(2), "dd.mm.yy") & IIf(v(2) = v(3), "", " - " & Format(v(3), "dd.mm.yy")), vbCrLf, "")) = 0
Next
orr(y + 1, 7) = Join(dit.Keys(), ", " & vbCrLf)
Next
End If
GetArr = orr
End Function
|